Application Project Umsatzprognose Bäckerei
Application Project Umsatzprognose Bäckerei
- Management Summary
- 1 Allgemeine Projektinformationen
- 2 Datenexploration
- 2.1 Einlesen der Daten
- 2.2 Überprüfung der Datenstrukturen
- 2.3 Überprüfung des Anfangs- und Endzeitpunkt der Datumsattribute in den Datensätzen
- 2.4 Überprüfung der Datensätze auf fehlende Werte
- 2.5 Überprüfung des Datensatzes auf Vollständigkeit
- 2.6 Überprüfung der Datensätze auf Ausreißer
- 2.7 Deskriptive Statistik
- 3 Datenaufbereitung, Erstellung von Rohdatensatz und Analysedatensätzen
- 3.1 Umgang mit Ausreißern
- 3.2 Umgang mit Warengruppe 6
- 3.3 Rohdaten mit vollständiger Zeitreihe
- 3.4 Vereinigung der Datensätze
- 3.5 Korrektur der Anzahl Nachkommastellen für einzelne Variablen
- 3.6 Umgang mit fehlenden Werten
- 3.7 Ergänzung um die Variablen Wochentag, Monat und Jahr
- 3.8 Ergänzung um Sommerferienvariablen
- 3.9 Ergänzung um Feiertagsvariablen
- 3.10 Ergänzung um Variable Jahreszeit
- 3.11 vollständige Datenreihe, Imputationen, Trainingsdaten, Testdaten
- 4 Deskriptive Analysen
- 5 Anwendung naiver Modelle
- 6 Anwendung statistischer Modelle - Lineare Regression
- 7 Anwendung von ML Verfahren: Decision Trees (Entscheidungsbäume)
- 8 Anwendung von ML Verfahren: Support Vector Machines (SVM)
- 9 Anwendung von DL Verfahren: Multilayer Perceptron (MLP)
- 10 Modellvergleich
- 11 Ensemble Methoden
- 12 Zusammenfassung und Ausblick
Management Summary
In dieser Projektarbeit werden Prognosemodelle entwickelt. Wir wollen damit für eine Bäckereifiliale den täglichen Umsatz pro Warengruppe schätzen.
Als Datenbasis stehen uns die historischen Umsätze für diese Filiale zur Verfügung. Den Zeitraum 2015 bis 2017 nutzen wir als Trainingsdaten für unsere Modelle. Die Prognosegüte bewerten wir dann anhand der 2018er Daten. Wir kennen die täglichen Umsätze für fünf Warengruppen: (1) Brot, (2) Brötchen, (3) Croissants, (4) Konditorei und (5) Kuchen.
Neben den Umsatzdaten binden wir Wetterdaten (Temperatur, Wind und Bewölkung), Veranstaltungsdaten (Kieler Woche) und weitere Einflussfaktoren (Feiertage, Ferien) in die Modellierung ein.
Wir testen Modelle aus insgesamt 5 verschiedenen Bereichen: Naive Modelle, die auf einfache Heuristiken zurück greifen, lineare Regressionsmodelle, Entscheidungsbäume, Support Vector Machines und Multilayer Perceptrons. Als sechstes Modell betrachten wir ein Ensemble, gebildet aus dem Mittelwert dieser Modelle.
Für die Bewertung der Modelle konzentrieren wir uns auf drei Gütekennzahlen: Die mittlere relative Abweichung (MPE) gibt uns Anhaltspunkte, ob ein Modell den Umsatz systematisch zu hoch oder zu niedrig schätzt. Solche Abweichungen können jedoch einfach mithilfe eines Offsets korrigiert werden. Ausschlaggebend ist der umsatzgewichtete Absolutwert der relativen Abweichung (WAPE) als Hauptkriterium für die Treffsicherheit eines Schätzers. Und daneben spielt die relative quadratische Abweichung eine Rolle bei der Bewertung der Prognosegüte, die besonders starke Schätzfehler misst und bewertet, die in der Praxis großen Einfluss auf den Gewinn / Verlust der Filiale haben.
Die verschiedenen Modelle schneiden für die einzelnen Warengruppe unterschiedlich ab. Für die Warengruppen 1 und 4 hat das Ensemble die Nase vorn. Aber auch jeweils ein Multilayer Perceptron, ein naives und ein lineares Modell liefert die besten Schätzwerte für die Warengruppen 2, 3 bzw. 5. Es gibt also kein klares Gewinnermodell.
Die besten Ergebnisse erzielen wir für die Warengruppen 2 (Brötchen) und 5 (Kuchen), die gleichzeitig die umsatzstärksten Warengruppen darstellen. Bei der Schätzung des täglichen Brötchen-Umsatzes liegen wir mit unserem Modell im Durchschnitt gut 10% daneben. Das ist unter Berücksichtigung der verwendeten Daten ein sehr gutes Ergebnis. Für die übrigen Warengruppen gibt es noch Verbesserungsbedarf. Möglicherweise kann man insbesondere die komplexen Modelle (Support Vector Machines und Multilayer Perceptrons) noch weiter verfeinern. Dafür fehlt uns jedoch die Erfahrung und hier ging es in erster Linie um die Anwendung dieser Modelle.
1 Allgemeine Projektinformationen
1.1 Ausgangslage
Die Bestellung von Bäckereien ist häufig noch ein manueller und zeitaufwändiger Prozess, der auf adjustierten Vorwochenwerten basiert. Eine systematische Planung unter Einbeziehung von Mustern findet nur eingeschränkt statt.
1.2 Zielsetzung
Wir testen verschiedene einfache und komplexe Modelle und bedienen uns dabei an Techniken aus den Bereichen Statistik, Machine Learning und Deep Learning. Möglicherweise finden wir ein Verfahren, dass den anderen überlegen ist und die beste Prognosegüte für alle Warengruppen aufweist.
Andererseits kann es sich herausstellen, dass das Verhalten der Warengruppen zu unterschiedlich ist und wir verschiedene Techniken für verschiedene Warengruppen benötigen.
In jedem Fall werden Prognosemodelle entworfen, die Bäckereien eine bessere Planungsgrundlage auf Warengruppenebene bieteen sollen.
Lösungsansatz
Mit Hilfe von verschiedenen Daten und Einflussfaktoren sollen die Umsätze je Warengruppe prognostiziert werden.
Abhängige / zu prognostizierende Variable:
- Umsatzdaten
Unabhängige / beeinflussende Variablen:
- Wetterdaten,
- Veranstaltungsdaten,
- Wochentage,
- Feiertage (sowie Feiertage inkl. Brückentage),
- Ferienzeiten
- Jahreszeiten
1.3 Datenbasis
Untersucht werden Daten für die Jahre 2013 bis 2019. Es liegen für diesen Zeitraum als Rohdaten drei Datensätze vor:
- Umsätze je Warengruppe und Tag
- Es werden fünf Warengruppen in die Analysen einbezogen: Brot (WG 1), Brötchen (WG 2), Croissant (WG 3), Konditorei (WG 4) und Kuchen (WG 5)
- Daten zur Kieler Woche
- Wetterdaten
- Informationen zu den Wetterdaten können der privaten Webseite von Mario Lehwald entnommen werden. Herr Lehwald hat seine Daten wiederum vom Geomar - Helmholtz-Zentrum für Ozeanforschung Kiel sowie vom Windfinder bezogen (vgl. Impressum)
2 Datenexploration
2.1 Einlesen der Daten
Im ersten Schritt müssen die Daten zunächst eingelesen werden um sie bearbeiten zu können:
2.2 Überprüfung der Datenstrukturen
- Datensatz Beispieldaten
## Classes 'spec_tbl_df', 'tbl_df', 'tbl' and 'data.frame': 11164 obs. of 3 variables:
## $ Datum : Date, format: "2013-07-01" "2013-07-02" ...
## $ Warengruppe: num 1 1 1 1 1 1 1 1 1 1 ...
## $ Umsatz : num 149 160 112 169 171 ...
## - attr(*, "spec")=
## .. cols(
## .. Datum = col_date(format = ""),
## .. Warengruppe = col_double(),
## .. Umsatz = col_double()
## .. )
## Observations: 11,164
## Variables: 3
## $ Datum <date> 2013-07-01, 2013-07-02, 2013-07-03, 2013-07-04, 2...
## $ Warengruppe <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,...
## $ Umsatz <dbl> 148.82835, 159.79376, 111.88559, 168.86494, 171.28...
## [1] "double"
## [1] "2019-07-30"
## [1] 1 6
## [1] 7.051201 1879.461831
## # A tibble: 6 x 3
## Datum Warengruppe Umsatz
## <date> <dbl> <dbl>
## 1 2013-07-01 1 149.
## 2 2013-07-02 1 160.
## 3 2013-07-03 1 112.
## 4 2013-07-04 1 169.
## 5 2013-07-05 1 171.
## 6 2013-07-06 1 175.
## # A tibble: 6 x 3
## Datum Warengruppe Umsatz
## <date> <dbl> <dbl>
## 1 2018-12-21 6 51.8
## 2 2018-12-22 6 66.7
## 3 2018-12-23 6 50.0
## 4 2018-12-24 6 46.1
## 5 2018-12-27 6 51.6
## 6 2018-12-28 6 35.2
Der Datensatz Beispieldaten ist ein Dataframe, enthält 11164 Zeilen und 3 Variablen:
- Datum (
date) - Warengruppe (
int) mit den Warengruppen 1 - 6 - Umsatz (
dbl) mit Werten zwischen 7.05 und 1879.46.
Umsätze werden jeweils 5 mit Nachkommastellen angezeigt. Hier wird später eine Änderung vorgenommen und die Variable auf zwei Nachkommastellen gerundet.
- Datensatz KiWo
## Classes 'spec_tbl_df', 'tbl_df', 'tbl' and 'data.frame': 72 obs. of 2 variables:
## $ Datum : Date, format: "2012-06-16" "2012-06-17" ...
## $ KielerWoche: num 1 1 1 1 1 1 1 1 1 1 ...
## - attr(*, "spec")=
## .. cols(
## .. Datum = col_date(format = ""),
## .. KielerWoche = col_double()
## .. )
## Observations: 72
## Variables: 2
## $ Datum <date> 2012-06-16, 2012-06-17, 2012-06-18, 2012-06-19, 2...
## $ KielerWoche <dbl> 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,...
any(KiWo$KielerWoche != 1) # Prüfung: Ist die Ausprägung in irgendeiner Zelle der Spalte ungleich 1?## [1] FALSE
## [1] TRUE
Der Datensatz KiWo enthält 71 Zeilen und die beiden Variablen Datum (date) und KielerWoche (int), wobei die einzige Ausprägung der Variablen KielerWoche die Ziffer 1 ist. Anhand der Daten der einzelnen Daten erkennt man, dass der Datensatz nur solche Daten enthält, an denen tatsächlich die Kieler Woche in dem jeweiligen Jahr stattgefunden hat.
- Datensatz Wetter
## Classes 'spec_tbl_df', 'tbl_df', 'tbl' and 'data.frame': 2601 obs. of 5 variables:
## $ Datum : Date, format: "2012-01-01" "2012-01-02" ...
## $ Bewoelkung : num 8 7 8 4 6 3 7 7 8 6 ...
## $ Temperatur : num 9.82 7.44 5.54 5.69 5.3 ...
## $ Windgeschwindigkeit: num 14 12 18 19 23 10 14 10 12 10 ...
## $ Wettercode : num 58 NA 63 80 80 NA 61 80 61 NA ...
## - attr(*, "spec")=
## .. cols(
## .. Datum = col_date(format = ""),
## .. Bewoelkung = col_double(),
## .. Temperatur = col_double(),
## .. Windgeschwindigkeit = col_double(),
## .. Wettercode = col_double()
## .. )
## Observations: 2,601
## Variables: 5
## $ Datum <date> 2012-01-01, 2012-01-02, 2012-01-03, 2012-...
## $ Bewoelkung <dbl> 8, 7, 8, 4, 6, 3, 7, 7, 8, 6, 6, 7, 2, 3, ...
## $ Temperatur <dbl> 9.825000, 7.437500, 5.537500, 5.687500, 5....
## $ Windgeschwindigkeit <dbl> 14, 12, 18, 19, 23, 10, 14, 10, 12, 10, 16...
## $ Wettercode <dbl> 58, NA, 63, 80, 80, NA, 61, 80, 61, NA, 51...
## [1] 0 8
## [1] -10.25000 32.67143
## [1] 3 35
## [1] 0 95
Der Datensatz Wetter enthält 2601 Zeilen und fünf Variablen:
- Datum (
date) - Bewoelkung (
int) mit Werte von 0 bis 8 - Temperatur (
dbl) mit Werten zwischen -10.25 und 32.67 Grad Celsius - Windgeschwindigkeit (
int) mit Werten zwischen 3 und 35 Knoten - Wettercode (
int) mit Werten zwischen 0 und 95, wobei die einzelnen Wettercodes einer bestimmten Wettererscheinung oder einem bestimmten Wetterzustand entsprechen.
Weitere Informationen zu den einzelnen Variablen des Datensatzes Wetter und ihrer Interpretation können der privaten Webseite Seewetter Kiel entnommen werden.
Alle Datensätze enthalten die Variable Datum. Folglich können die einzelnen Datensätze später über diese Variable vereinigt werden.
2.3 Überprüfung des Anfangs- und Endzeitpunkt der Datumsattribute in den Datensätzen
## [1] "2013-07-01" "2019-07-30"
## [1] "2012-06-16" "2019-06-30"
## [1] "2012-01-01" "2019-08-01"
- Die Daten des Datensatzes Beispieldaten reichen vom 01.07.2013 bis zum 30.07.2019.
- Die Daten des Datensatzes KiWo reichen vom 16.06.2012 bis zum 30.06.2019.
- Die Daten des Datensatzes Wetter reichen vom 01.01.2012 bis zum 01.08.2019.
2.4 Überprüfung der Datensätze auf fehlende Werte
Überprüfung auf “klassische” fehlende Werte (NA)
Zunächst einmal wird geprüft, welche klassischen fehlenden Werte (NA) in den einzelnen Datensätzen vorhanden sind:
## [1] 0
## [1] 0
## [1] 679
## [1] 0
## [1] 10
## [1] 0
## [1] 0
## [1] 669
- Der Datensatz Beispieldaten enthält keine fehlenden Werte.
- Der Datensatz KiWo enthält keine fehlenden Werte.
- Der Datensatz Wetter enthält 679 fehlende Werte, davon 10 in der Spalte “Bewoelkung”, 669 in der Spalte “Wettercode”.
2.5 Überprüfung des Datensatzes auf Vollständigkeit
In In einem weiteren Schritt wird geprüft, ob die Anzahl der Zeilen pro Jahr stimmt.
In den Jahren 2014, 2015, 2017 und 2018, die vollständig vorliegen, müssten es je Warengruppe 365 Zeilen sein, im Schaltjahr 2016 366. Für das Jahr 2013, für das Daten erst ab dem 01.07.2013 zur Verfügung stehen, entsprechend 183 und für das unvollständige Jahr 2019 müssten 210 Datensätze vorliegen. Insgesamt müssten für jede Warengruppe demnach 2219 Zeilen vorhanden sein.
Beispieldaten <- Beispieldaten %>% mutate(Jahr = year(Datum))
# 2174 -> 45 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 1) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 2174
## # A tibble: 1 x 1
## n
## <int>
## 1 2174
## # A tibble: 1 x 1
## n
## <int>
## 1 2174
## # A tibble: 1 x 1
## n
## <int>
## 1 2120
## # A tibble: 1 x 1
## n
## <int>
## 1 2174
Es fehlen bei allen Warengruppen Datensätze. Bei den Warengruppen 1,2, 3 und 5 fallen ca. 70% der fehlenden Daten auf Feiertage (insb. Karfreitag, Tag der Arbeit und 1. und 2. Weihnachtsfeiertag). Bei Warengruppe 4 sind es ca. 30%. Weitere ~30% der fehlenden Daten der Warengruppe 4 liegen in den Sommermonaten Juni, Juli, August. Eine Möglichkeit wäre, dass die Kühlung ausgefallen ist / einen Defekt hatte und demzufolge keine Konditoreiwaren angeboten wurden. Eine andere Möglichkeit wäre, dass bei sehr trockenem, warmen Wetter der Verkauf von Konditoreiwaren in der Regel ein Minusgeschäft ist und daher das Sortiment temporär/tageweise verkleinert wird. Auffällig ist, dass die Anzahl der fehlenden Werte pro Jahr abnehmend ist und sich insbesondere in den Jahren 2013 und 2018 mehrheitlich auf Feiertage beschränkt.
Untersucht man die einzelnen Jahre genauer, ergibt sich folgendes Bild:
# 181 -> ein Datum fehlt
Beispieldaten %>%
filter(Warengruppe == 1 & Jahr == 2013) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 181
# 181 -> ein Datum fehlt
Beispieldaten %>%
filter(Warengruppe == 2 & Jahr == 2013) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 181
# 181 -> ein Datum fehlt
Beispieldaten %>%
filter(Warengruppe == 3 & Jahr == 2013) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 181
# 165 -> 17 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 4 & Jahr == 2013) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 165
# 181 -> ein Datum fehlt
Beispieldaten %>%
filter(Warengruppe == 5 & Jahr == 2013) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 181
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 1 & Jahr == 2014) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 2 & Jahr == 2014) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 3 & Jahr == 2014) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 334 -> 31 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 4 & Jahr == 2014) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 334
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 5 & Jahr == 2014) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 360 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 1 & Jahr == 2015) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 360
# 360 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 2 & Jahr == 2015) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 360
# 360 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 3 & Jahr == 2015) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 360
# 350 -> 15 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 4 & Jahr == 2015) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 350
# 360 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 5 & Jahr == 2015) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 360
# 356 -> 10 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 1 & Jahr == 2016) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 356
# 356 -> 10 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 2 & Jahr == 2016) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 356
# 356 -> 10 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 3 & Jahr == 2016) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 356
# 352 -> 14 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 4 & Jahr == 2016) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 352
# 356 -> 10 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 5 & Jahr == 2016) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 356
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 1 & Jahr == 2017) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 2 & Jahr == 2017) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 3 & Jahr == 2017) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 4 & Jahr == 2017) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 5 & Jahr == 2017) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 358 -> 7 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 1 & Jahr == 2018) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 358
# 358 -> 7 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 2 & Jahr == 2018) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 358
# 358 -> 7 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 3 & Jahr == 2018) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 358
# 357 -> 8 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 4 & Jahr == 2018) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 357
# 358 -> 7 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 5 & Jahr == 2018) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 358
# 205 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 1 & Jahr == 2019) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 205
# 205 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 2 & Jahr == 2019) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 205
# 205 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 3 & Jahr == 2019) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 205
# 205 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 4 & Jahr == 2019) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 205
# 205 -> 5 Daten fehlen
Beispieldaten %>%
filter(Warengruppe == 5 & Jahr == 2019) %>%
summarise(n = n())## # A tibble: 1 x 1
## n
## <int>
## 1 205
Je Warengruppe und Jahr fehlen unterschiedliche viele Datensätze.
2.6 Überprüfung der Datensätze auf Ausreißer
Ein Ausreißer ist ein Wert, der außerhalb der üblichen Struktur einer Verteilung liegt. Zunächst wird in einem ersten Schritt mittels einer Visualisierung in Form von boxplots überprüft, ob die einzelnen Datensätze überhaupt Ausreißer enthalten.
Ein Boxplot zeigt uns den Median (dicke Linie) sowie das untere und obere Quartil (als Box). Der Abstand von unterem zu oberem Quartil (interquartile range: IQR) wird standardmäßig mit 1.5 multipliziert. Und genau über die auf diese Art ermittelte Spannweite erstrecken sich die sogenannten whiskers maximal, wobei die whiskers unten und oben an der Box ansetzen. Gibt es darüber hinaus noch Werte, die weiter außerhalb liegen, werden diese als Ausreißer durch Punkte gekennzeichnet.
Die Überprüfung wird begonnen mit dem Datensatz Beispieldaten:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 7.051 97.787 165.494 208.308 282.592 1879.462
Das Attribut Umsatz enthält zahlreiche Ausreißer. Mit bloßem Auge ist nicht zu erkennen, wie viele Ausreißer es genau sind. Die Ausreißer werden also in einem 2. Schritt genauer betrachtet, um die genaue Anzahl der Ausreißer zu ermitteln. Statistiker haben viele Verfahren entwickelt, um auseinanderzuhalten, was man als Ausreißer bezeichnen sollte, und was nicht.
Wir verwenden - wie bereits erwähnt - die Standardeinstellung, die aus einer Definition von John W. Tukey stammt: Sie definiert einen Ausreißer als einen Punkt, der mehr als \[1,5 * IQR\] vom unteren bzw. oberen Quartil abweicht. Anders gesagt liegen untere Ausreißer unterhalb
\[Q_1 - 1,5 * IQR\] und obere Ausreißer oberhalb
\[Q_3 + 1.5 * IQR\]
Vereinfachend untersuchen wir nun die Umsatzvariable insgesamt auf Ausreißer, wobei wir zunächst nicht nach Warengruppen trennen:
g_oben <- quantile(Beispieldaten$Umsatz, probs=0.75) + (1.5*IQR(Beispieldaten$Umsatz)) #Obere Grenze fuer Ausreißer
g_oben## 75%
## 559.7999
## # A tibble: 1 x 1
## n
## <int>
## 1 348
Die obere Grenze für Ausreißer liegt demzufolge bei 559,80€ (gerundet). Es gibt insgesamt 348 Ausreißer in der Variable Umsatz. In einem 3. Schritt betrachten wir, an welchen Daten diese Ausreißer auftreten und ob Muster erkennbar sind (z. B. überproportional hohe Umsätze an Ostern oder anderen Feiertagen, in den Ferien, während der Kieler Woche o. Ä.):
## # A tibble: 348 x 3
## Datum Umsatz Warengruppe
## <date> <dbl> <dbl>
## 1 2013-07-06 632. 2
## 2 2013-07-07 695. 2
## 3 2013-07-09 586. 2
## 4 2013-07-10 567. 2
## 5 2013-07-11 569. 2
## 6 2013-07-12 600. 2
## 7 2013-07-13 747. 2
## 8 2013-07-14 777. 2
## 9 2013-07-15 597. 2
## 10 2013-07-17 628. 2
## # ... with 338 more rows
Beispieldaten %>%
dplyr::select(Datum, Umsatz, Warengruppe) %>%
filter(Umsatz > g_oben) %>%
arrange(desc(Umsatz))## # A tibble: 348 x 3
## Datum Umsatz Warengruppe
## <date> <dbl> <dbl>
## 1 2014-12-31 1879. 5
## 2 2015-12-31 1870. 5
## 3 2016-12-31 1705. 5
## 4 2018-12-31 1668. 5
## 5 2013-12-31 1626. 5
## 6 2017-12-31 1432. 5
## 7 2014-05-05 1203. 2
## 8 2013-08-03 931. 2
## 9 2014-08-09 875. 2
## 10 2013-07-28 872. 2
## # ... with 338 more rows
## # A tibble: 4 x 3
## Datum Umsatz Warengruppe
## <date> <dbl> <dbl>
## 1 2018-12-31 264. 1
## 2 2018-12-31 618. 2
## 3 2018-12-31 255. 3
## 4 2018-12-31 1668. 5
Erste Erkenntnisse (nach Jahren sortiert):
- Eine erste Ausreißerperiode ist - mit zwei Ausnahmetagen (Mo, 08.07.; Di, 16.07.) - in dem Zeitraum vom 06.07.2013 (Samstag) bis zum 04.08.2013 (Sonntag) zu beaobachten. Vergleicht man diese Periode mit den Ferienzeiten der verschiedenen Bundesländer im Jahr 2013, so fällt auf, dass insbesondere die für den Tourismus in Schleswig-Holstein relevanten Bundesländer Hessen, Niedersaschsen, Rheinland-Pfalz, sowie teilweise Nordrhein-Westfalen (ab. 22.07.) in diesem Zeitraum Ferien hatten. Weiterhin lagen auch die Ferien der Berliner und der Schleswig-Holsteiner selbst sowie die der Bayern teilweise in diesem Zeitraum. Die Vermutung liegt insofern nahe, dass die Sommerferien einen signifikanten Einfluss auf die Höhe des Umsatzes der betrachtenen Filiale haben.
- Nach dieser wirklich sichtbaren, anhaltenden Periode von überproportional hohen Umsätzen folgt eine Phase - beginnend am Samstag, 10.08.2013 -, in der ausschließlich an den beiden Wochenendtagen Ausreißer-Umsätze zu beobachten sind. Diese Phase endet am 08.09.2013 (Ausnahme in dieser Phase ist So, 01.09.).
- Nach dieser Wochenend-Ausreißerphase wird es erkennbar unregelmäßiger:
- vereinzelt gibt es weiterhin Ausreißer an Wochenendtagen (z. B. am So, 28.09.; So, 17.11.; So, 24.11.; 01.12.; 25.12.)
- auch an einzelnen Feiertagen / besonderen Ereignissen sind die Umsätze überproportional stark (03.10. (Tag der Deutschein Einheit); 31.12. (Silvester)).
- die Herbst- und Winterferien sowie Weihnachten bzw. die Weihnachtsfeiertage scheinen insofern keinen signifikanten Einfluss auf die Umsätze der Bäckerei zu haben.
- Insgesamt gibt es im Jahr 2013 zwei Tage (So, 11.08. und Di, 31.12.), an denen zwei Warengruppen Ausreißer sind (jeweils Warengruppen 2 + 5).
- Das Jahr 2014 beginnt strukturell so wie das Vorjahr geendet hat: unregelmäßig. Vereinzelt gibt es Ausreißer an Wochenendtagen (So, 12.01.; jeweils der Sonntag in der Zeit vom 09.02. - 09.03.; Sa, 29.03.; So, 06.04.).
- Ab Sa, 12.04. bis Ende April am So, 27.04. sind jeweils beide Wochenendtage überproportional stark (Anmerkung: Ferienzeit in vielen relevanten Bundesländern); auch an Ostern (Karfreitag 18.04., Ostersonntag 20.04. sowie Ostermontag 21.04.) sind starke Umsatz-Effekte zu beobachten.
- Ein ungewöhnlich hoher Umsatz ist am Montag, 05.05.2014 zu beobachten; es ist der höchste Umsatz im gesamten Zeitraum; ansonsten gibt es an den Sonntagen 18.05 und 25.05. Ausreißer sowie an Christi Himmelfaht (29.05.).
- Im Zeitraum vom 31.05. bis 29.06. erstrecken sich die Ausreißer wiederum über beide Wochentage; hinzu kommt in diesem Zeitraum ein (eingeschränkter) Effekt der Kieler Woche (Ausreißer am Do, 26.06. und Fr, 27.06.).
- Im Juli sind am Sa, 05.07. sowie von Fr, 11.07. - So, 13.07 die “üblichen” Wochenendeffekte zu beobachten.
- Im Zeitraum vom 17.07. - 31.08 - also in einem Zeitraum von ca. 6 Wochen - jeden Tag Ausreißer zu verzeichnen; betrachtet man die Sommerferienzeiträume der Bundesländer im Jahr 2014, so liegt die Vermutung nahe, dass wie schon im Vorjahr die Ferienzeit diese überporportional hohen Umsätze signifkant beeinflusst hat.
- An den ersten drei Septemberwochenenden sowie an den Oktoberwochenenden sind ebenfalls Ausreißer zu verzeichnen; hinzu kommt im Oktober zudem der Tag der Deutschen Einheit.
- Im November beschränken sich die Ausreißerumsätze auf die Sonntage; dies gilt mit Ausnahme des So, 21.12. auch für den Dezember; hinzu kommen im Dezember weiterhin der Di, 30. und der Mi, 31.12; auch im Jahr 2014 ist wieder kein “Weihnachts-Effekt” sichtbar.
- Insgesamt gibt es im Jahr 2014 einen Tag (Mi, 31.12.), an denen zwei Warengruppen Ausreißer sind (jeweils WG 2 + 5). Am 05.05. gibt es sogar Ausreißer in drei Warengruppen (WG 2, 3, 5).
- Mit mehr als 120 Ausreißern innerhalb eines Jahres ist das Jahr 2014 ein vglw. außergewöhnlich “ausreißerstarkes” Jahr (gewöhnlich liegt die Anzahl pro Jahr zwischen ~ 30 - 50 Ausreißern). Man könnte das Jahr 2014 selbst fast als Ausreißerjahr bezeichnen.
- Im Zeitraum Januar bis März sind insgesamt nur vier Ausreißer zu beobachten; diese liegen jeweils auf einem Sonntag
- Das Osterwochenende im April (So, 05.04 + Mo, 06.04.) ist gewohnt stark; im Unterschied zu 2014 ist jedoch an Karfreitag kein Ausreißer-Umsatz zu verzeichnen. Ansonsten ist der April nicht von Ausreißern betroffen.
- Der Monat Mai + Anfang sind vergleichbar mit dem Vorjahr: überproportional hohe Umsätze am Sonntag nach Himmelfahrt (17.05.) sowie am Pfingstwochende (So, 24. + Mo, 25.05.).
- Der Juni erscheint schwächer als im Vorjahr; es ist lediglich ein leichter Wochenendeffekt sichtbar (Sa, 13.06., Sa, 20.06; sowie am zweiten “KiWo-Wochenende” 27. + 28.06.), der Effekt der Kieler Woche ist schwächer im Vergleich zum Vorjahr.
- Auch im Jahr 2015 scheinen die Sommerferien einen Einfluss zu haben, jedoch einen geringeren als im Vorjahr:
- im Juli sind in den ersten drei Wochen (01.07. - 19.07.) nur Wochenendeffekte zu beobachten
- die Phase, in der jeder Tag ein Ausreißer ist, erstreckt sich 2015 nur über 3 Wochen (20.07. - 09.08.); in der Woche vom 10.08 - 16.08. sind zwar noch vier Ausreißer zu verzeichnen, ansonsten beschränken sich die Ausreißer im Rest des Augustes auf die Wochenenden.
- Der nächste und einzige weitere Ausreißer im Jahr 2015 ist an Silvester zu beobachten.
- Im Jahr 2016 taucht der erste Ausreißer am Sonntag des ersten Februarwochenendes auf (07.02.).
- Das Osterwochenende Ende März (Sa, 04.04 + Mo, 06.04.) ist abermals stark, an jedem Tag sind Ausreißer zu finden.
- Im April gibt es im Jahr 2016 keinen einzigen Ausreißer, wobei in diesem Jahr auch kein Feiertag in den April fällt.
- Wie schon im Vorjahr ist an Christi Himmelfahrt (05.05.) selbst kein Ausreißer zu beobachten, wohl aber an dem darauf folgenden Sonntag (wie 2015). Ein weiterer Ausreißer im Mai liegt auf dem Pfingstmontag (16.05.).
- Die Kieler Woche-Umsätze sind abermals schwach mit Blick auf Ausreißer; lediglich am 2. KiWo-Wochenende sind Ausreißer zu verzeichnen.
- Die Sommerferienzeit von Ende Juli bis Mitte August ist wie gewohnt mit vielen Ausreißern versehen, jedoch weniger als in den beiden Vorjahren. Ende August beschränken sich die Ausreißer auf die beiden Wochenendtage.
- Der Rest des Jahres verläuft ausreißertechnisch typisch. Es gibt zwei vereinzelte Ausreißer an zwei Sonntagen (02.10. und 18.12); Silvester ist erwartbar stark, sowohl in Warengruppe 2 als auch in Warengruppe 5.
- Was AUsreißer anbelangt, ist das Jahr 2017 ein auffällig schwaches Jahr. Es ist mit knapp 30 Ausreißern im ganzen Jahr das schwächste von allen (Vgl. 2014: > 120).
- Die ersten beiden Ausreißer sind erst im April am Osterwochenende (15. + 16.04.) zu beobachten; ein weiterer Ausreißer kommt am letzten Aprilsonntag vor, im Mai gibt es nur einen Ausreißer am Sonntag nach Christi Himmelfahrt.
- Im Juni gibt es einen bemerkenswerten Ausreißer am Mo, 05.06. (Montag generell ungewöhnlich für Ausreißer); weiterhin sind an den beiden KiWo-Wochenenden Ausreißer zu verzeichnen.
- Ein gewisser Sommerferieneffekt ist sichtbar, dieser ist jedoch deutlich schwächer al sin den Vorjahren.
- Bemerkenswert ist ein zweiter Ausreißer an Heiligabend. 2017 ist das einzige Jahr, in dem Weihnachten bzw. genauer Heiligabend einen Ausreißer in der Warengruppe 2 zu verzeichnen hat.
- Zudem ist 2017 das einzige Jahr, in dem an Silvester kein Ausreißer in Warengruppe 2 zu beobachten ist.
Fazit: Insgesamt ein eher untypisches Jahr was Ausreißer anbelangt, sowohl von der Anzahl her als auch teilweise von der Verteilung.
- Im Jahr 2018 gibt es einen ersten Ausreißer am Ostersonntag Anfang April (01.04.); der Mai profitiert von der Lage von Christi Himmelfahrt und Pfingsten.
- Im Juni sind an den beiden Wochenenden vor der KiWo einzelne Ausreißer zu verzeichnen; das erste KiWo-Wochenende ist stark. Insbesondere der Sa, 23.06. ist auffällig, das es der einzige Samstag ist, an dem für zwei Warengruppen (2 + 5) Ausreißer zu verzeichnen sind.
- Der gewohnte Sommerferien-Effekt ist von Mitte Juli bis Mitte August bemerkbar und wieder deutlich stärker als im Vorjahr. Ein letzter Ausreißer im August ist am Sa, 25.08. zu verzeichnen. Danach gibt es im gesamten Jahresverlauf nur noch den gewohnten Silvesterausreißer.
- Im Jahr 2019 gibt es zwei vereinzelte Sonntags-Ausreißer Ende Februar und Ende März.
- Ostern, Christi Himmelfahrt und Pfingsten sind gewohnt stark:
- Ostern: Ausreißer von Sa, 20.04. - Mo, 22.04.
- Christi Himmelfahrt: Sowohl an Christi Himmelfahrt selbst (30.05.) als auch am darauffolgenden Samstag (01.06.) sind Ausreißer beobachtbar.
- Am Pfingstwochenende (Sa, 08. - Mo, 10.06.) sind an allen Tagen Ausreißer zu verzeichnen.
- Wiederum stark im Juni sind die beiden Kieler Woche-Wochenenden (22.-23. sowie 29.-30.06.).
- Der Sommerferieneffekt beginnt Mitte Juli (Sa, 13.07.) und hält bis zum Ende des Monats an.
Am Ende der Auswertung wird deutlich, dass für einzelne Daten, z. B. den 05.05.2014, auffällig hohe Umsätze in mehreren Warengruppen vorliegen. Eine Überprüfung auf doppelt belegte Daten ergibt:
Beispieldaten %>%
dplyr::select(Datum, Umsatz, Warengruppe) %>%
filter(Umsatz > g_oben) %>%
arrange(desc(Umsatz)) %>%
filter(duplicated(Datum))## # A tibble: 9 x 3
## Datum Umsatz Warengruppe
## <date> <dbl> <dbl>
## 1 2014-05-05 749. 5
## 2 2018-06-23 662. 5
## 3 2015-12-31 644. 2
## 4 2014-12-31 643. 2
## 5 2018-12-31 618. 2
## 6 2013-12-31 586. 2
## 7 2013-08-11 583. 5
## 8 2016-12-31 570. 2
## 9 2014-05-05 566. 3
# Gegenprüfung
Beispieldaten %>%
dplyr::select(Datum, Umsatz) %>%
filter(Umsatz > g_oben) %>%
arrange(desc(Umsatz)) %>%
distinct(Datum) ## # A tibble: 339 x 1
## Datum
## <date>
## 1 2014-12-31
## 2 2015-12-31
## 3 2016-12-31
## 4 2018-12-31
## 5 2013-12-31
## 6 2017-12-31
## 7 2014-05-05
## 8 2013-08-03
## 9 2014-08-09
## 10 2013-07-28
## # ... with 329 more rows
Für acht Daten ergibt sich, dass für diese mehrere Umsätze für einen Tag eingetragen wurden:
- 2013-08-11: 666.91€ (WG 2), 583.49 € (WG 5)
- 2013-12-31: 586.13€ (WG 2), 1625.69€ (WG 5)
- 2014-05-05: 1203.43€ (WG 2), 565.94€ (WG 3), 749.22€ (WG 5)
- 2014-12-31: 643.37€ (WG 2), 1879.46€ (WG 5)
- 2015-12-31: 643.67€ (WG 2), 1869.94€ (WG 5)
- 2016-12-31: 569.61€ (WG 2), 1705.14€ (WG 5)
- 2018-06-23: 706.42€ (WG 2), 662.37€ (WG 5)
- 2018-12-31: 618.31€ (WG 2), 1668.12€ (WG 5)
Auch die Über- bzw. Gegenprüfung bestätigt dies: es gibt nur 339 nicht doppelte Fälle gibt.
Zusammenfassung der Erkenntnisse:
- Warengruppe 2 (Brötchen) ist mit großem Abstand die Warengruppe mit den meisten Ausreißern, diese sind in jedem Jahr überwiegend in der Sommerfereinzeit zu verzeichnen. Weitere Ausreißer gibt es in Warengruppe 5 (Kuchen). Die Ausreißer der WG 5 sind insbesondere an Silvester zu beobachten. Einen einzelnen Ausreißer gibt es in der WG 3 (Croissant) am 05.05.2014.
- Die Struktur der Verteilung der Ausreißer ist in allen Jahren ähnlich, hat jedoch gewisse Abweichungen in den einzelnen Jahren (vgl. bspw. die Verteilung der Ausreißer in den Jahren 2014 und 2017). Was die Anzahl Ausreißer insgesamt pro Jahr anbelangt, gibt es deutliche Schwankungen. Dies sollte ggf. bei den weitergehenden Analysen noch einmal gesondert berücksichtigt werden.
- Die Sommerferien (der Tourismus) scheinen einen signifikanten Einfluss auf den Umsatz zu haben; dies gilt nicht für die übrigen Ferien des Jahres. Allerdings scheint es ebenfalls entscheidend zu sein, wie die Sommerferien in den einzelnen Bundesländern liegen (starten die Fereien vglw. früh oder eher spät, gibt es Überschneidungen bei großen BuLä, wie lange dauern diese Überschneidungen an)
- Das Wochenende ist insgesamt ebenfalls ein bedeutender Einflussfaktor; dieser Effekt beschränkt sich jedoch zeitweise nur auf den Sonntag (je nach Jahreszeit).
- Die Kieler Woche beeinflusst die Umsätze der betrachteten Filiale in einzelnen Jahren des betrachteten Zeitraums maßgeblich, der Effekt ist jedoch nicht allzu groß.
- Feiertage haben nur teilweise einen bedeutsamen Einfluss auf den Umsatz (Ostern, Christi Himmelfahrt, Pfingsten, Tag der Deutschen Einheit, Silvester, nicht jedoch Weihnachten); andere Feiertage wie der Reformationstag haben keinen Einfluss.
- Die stärksten Ausreißer eines jeden der betrachteten Jahre sind jeweils an Silvester zu verzeichnen.
Als nächstes wird der Datensatz Wetter auf Ausreißer hin überprüft:
Nur die Variable Windgeschwindigkeit enthält 7 Ausreißer (Stürme).
2.7 Deskriptive Statistik
Wir werfen einen ersten Blick auf den Gesamtumsatz und den Mittelwert des Umsatzes je Warengruppe.
## Warengruppe
## 1 2 3 4 5 6
## 272046.42 874857.56 364835.24 184680.16 605741.79 23386.15
## Warengruppe
## 1 2 3 4 5 6
## 125.13635 402.41838 167.81750 87.11328 278.63008 67.20159
Wir prüfen nun, wie viele Datensätze wir je Warengruppe vorfinden und über welchen Zeitraum sich die Datensätze erstrecken.
## # A tibble: 6 x 2
## Warengruppe n
## <dbl> <int>
## 1 1 2174
## 2 2 2174
## 3 3 2174
## 4 4 2120
## 5 5 2174
## 6 6 348
## # A tibble: 6 x 3
## Warengruppe min_dat max_dat
## <dbl> <date> <date>
## 1 1 2013-07-01 2019-07-30
## 2 2 2013-07-01 2019-07-30
## 3 3 2013-07-01 2019-07-30
## 4 4 2013-07-01 2019-07-30
## 5 5 2013-07-01 2019-07-30
## 6 6 2013-10-24 2018-12-28
Für die Warengruppen 1, 2, 3 und 5 gibt es jeweils 2.174 Datensätze, für die Warengruppe 4 sind es 2.120 Datensätze. Auffällig ist, dass es für die Warengruppe 6 nur 348 Datensätze gibt.
Die Datensätze für die ersten 5 Warengruppen erstrecken sich über denselben Zeitraum: 1.7.2013 bis 30.7.2019. Die erste Vermutung war, dass für die 6. Warengruppe nur ein eingeschränkter Zeitraum zur Verfügung steht. Dieser Verdacht wird widerlegt: Der Zeitraum der Daten für die 6. Warengruppe ist nur geringfügig kürzer und geht vom 24.10.2013 bis 28.12.2018.
Entscheidung: Die Warengruppe 6 wird in der Modellierung nicht betrachtet.
Welches sind die 20 umsatzstärksten Tage des Jahres (Gesamtumsatz pro Tag)?
Beispieldaten %>%
dplyr::select(Datum, Umsatz) %>%
group_by(Datum) %>%
summarise(Gesamtumsatz = sum(Umsatz)) %>%
arrange(desc(Gesamtumsatz)) %>%
top_n(20)## Selecting by Gesamtumsatz
## # A tibble: 20 x 2
## Datum Gesamtumsatz
## <date> <dbl>
## 1 2014-05-05 3156.
## 2 2015-12-31 3015.
## 3 2014-12-31 2939.
## 4 2018-12-31 2805.
## 5 2016-12-31 2773.
## 6 2013-12-31 2615.
## 7 2017-12-31 2378.
## 8 2014-08-18 2121.
## 9 2014-06-28 2096.
## 10 2019-06-29 2035.
## 11 2013-08-03 2022.
## 12 2016-08-13 2014.
## 13 2014-08-24 1989.
## 14 2019-04-20 1988.
## 15 2018-06-23 1987.
## 16 2014-08-23 1975.
## 17 2014-08-09 1958.
## 18 2018-08-18 1950.
## 19 2017-04-15 1950.
## 20 2014-08-16 1934.
Üblicherweise bilden die Silvestertage mit Abstand die Umsatzspitzen. Bereits vorher war uns der 05.05.2014 aufgefallen, den wir später genauer untersuchen werden.
3 Datenaufbereitung, Erstellung von Rohdatensatz und Analysedatensätzen
3.1 Umgang mit Ausreißern
Zwei der 7 verbleibenden Variablen enthalten Ausreißer: Umsatz und Windgeschwindigkeit. Beim Umgang mit den vorhandenen Ausreißern muss differenziert werden, ob es sich um unerwartete / nicht prognostizierbare Ausreißer handelt oder ob diese in gewisser Hinsicht planbar sind, weil sie erwartbar sind, da sie in allen Jahren gleichermaßen zu beobachten sind (z.B. Silvester). Prognostizierbare Ausreißer werden im weiteren Verlauf kodiert, d.h. es werden Variablen für diese planbaren Ausreißer angelegt.
Was die vorliegenden Daten anbelangt, sind einzig die Umsätze am Montag, 05.05.2014 auf den ersten Blick nicht zu erklären. Dieser Tag ist der umsatzstärkste Tag im gesamten Zeitverlauf. Zudem ist es der einzige Tag im gesamten Datensatz, bei dem es Ausreißer für drei Warengruppen gibt (ansonsten beschränken sich die Ausreißer weitestgehend auf Warengruppe 2, vereinzelt gibt es Tage, an denen auch Warengruppe 5 Ausreißer aufweist, z.B. an Silvester).
Bei genauerem Hinsehen haben wir festgestellt, dass für die beiden Vortage 03.05.2014 und 04.05.2014 keine Umsatzdaten vorliegen und zwar für alle Warengruppen. Der Verdacht liegt nahe, dass die Umsätze für den Zeitraum 03.-05.05.2014 summiert für den 05.05.2014 angesetzt wurden. Wir finden nämlich für den 05.05.2014 insgesamt einen Umsatz in Höhe von 3.156. Für den Vergleichszeitraum eine Woche später (10.-12.05.2014) finden wir einen Gesamtumsatz in vergleichbarer Höhe: 3.267. Es handelt sich bei keinem der Tage um einen Feiertag.
Wir korrigieren die Werte für den Zeitraum 03.-05.05.2014 und setzen dafür vereinfachend die Werte der Folgewoche ein. Wir erstellen einen Datensatz df als Kopie der Beispieldaten. Dann löschen wir zunächst den 05.05.2014, laden die korrigierten Werte für den 03.-05.05.2014 aus dem Datensatz Beispieldaten_Korrektur.csv und verknüpfen ihn mit df.
Beispieldaten %>%
group_by(Datum) %>%
filter(Datum=="2014-05-05") %>%
summarise(Summe_Umsatz=sum(Umsatz))## # A tibble: 1 x 2
## Datum Summe_Umsatz
## <date> <dbl>
## 1 2014-05-05 3156.
Beispieldaten %>%
filter(Datum >= "2014-05-10" & Datum <= "2014-05-12") %>%
group_by(Datum) %>%
summarise(Summe_Umsatz=sum(Umsatz))## # A tibble: 3 x 2
## Datum Summe_Umsatz
## <date> <dbl>
## 1 2014-05-10 1209.
## 2 2014-05-11 1192.
## 3 2014-05-12 867.
# erzeuge df vor Korrektur der Beispieldaten
df <- Beispieldaten
# entferne alte Werte für den 05.05.2014
df <- df %>% filter(Datum != "2014-05-05")
# lese korrigierte Datensätze ein und füge Attribut Jahr hinzu
Beispieldaten_korr <- read_csv("data/Beispieldaten_Korrektur.csv")## Parsed with column specification:
## cols(
## Datum = col_date(format = ""),
## Warengruppe = col_double(),
## Umsatz = col_double()
## )
Beispieldaten_korr <- Beispieldaten_korr %>% mutate(Jahr = year(Datum))
# verknüpfe df mit den korrigierten Datensätzen
df <- rbind(df, Beispieldaten_korr)
df %>% filter(Datum == "2014-05-05")## # A tibble: 5 x 4
## Datum Warengruppe Umsatz Jahr
## <date> <dbl> <dbl> <dbl>
## 1 2014-05-05 1 118. 2014
## 2 2014-05-05 2 329. 2014
## 3 2014-05-05 3 124. 2014
## 4 2014-05-05 4 67.5 2014
## 5 2014-05-05 5 229. 2014
Da die anderen Ausreißer durch jeweilige Sondereffekte zu erklären sind (Wochenende, Feiertag, Brückentag etc.) werden diese Ausreißer im Datensatz belassen und im Fortgang hierfür gesonderte Variablen angelegt.
3.2 Umgang mit Warengruppe 6
Die Anzahl der Datensätze je Warengruppe differiert teilweise stark, insbesondere Warengruppe 6 ist auffällig:
- Warengruppen 1, 2, 3 und 5: jeweils 2.174 Datensätze
- Warengruppe 4: 2.120 Datensätze
- Warengruppe 6: 348 Datensätze.
Die Datensätze der Warengruppe 6 werden infolgedessen gelöscht:
Nach dem Löschen der Datensätze enthält der Datensatz nunmehr 10826 Zeilen.
3.3 Rohdaten mit vollständiger Zeitreihe
Zunächst wird ein weiterer Datensatz df_voll erstellt, der eine komplette Zeitreihe enthält vom 1.7.2013 bis 31.7.2019 für alle Warengruppen 1 bis 5. Dabei wird in Kauf genommen, dass dieser zunächst viele fehlende Werte enthalten wird, die im weiteren Verlauf für die einzelnen Modelle sinnvoll zu ergänzen sind:
3.4 Vereinigung der Datensätze
Bei der Untersuchung der Datumsvariablen der einzelnen Datensätze ergab sich, dass diese über unterschiedliche Zeiträume reichen:
- Die Daten des Datensatzes Beispieldaten reichen vom 01.07.2013 bis zum 30.07.2019, sind aber teilweise unvollständig. Es fehlen bspw. für alle Warengruppen Daten für den Tag der Arbeit, Weihnachten, Neuhjahr etc. Weiterhin fehlen insbesondere bei der Warengruppe 4 immer wieder einzelne Daten in den Sommermonaten, vereinzelt auch an einzelnen Tagen im Herbst.
- Die Daten des Datensatzes KiWo reichen vom 16.06.2012 bis zum 30.06.2019.
- Die Daten des Datensatzes Wetter reichen vom 01.01.2012 bis zum 01.08.2019.
Maßgeblich ist für uns der Zeitraum der vollstängien Zeitreihe df_voll vom 01.07.2013 bis zum 31.07.2019. Wir fügen über ein left_join die Daten zur Kieler Woche und die Wetterdaten an.
df_voll <- left_join(df_voll, KiWo, by = "Datum")
df_voll <- left_join(df_voll, Wetter, by = "Datum")
head(df_voll)## # A tibble: 6 x 9
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2013-07-01 1 149. 2013 NA 6 17.8
## 2 2013-07-01 2 536. 2013 NA 6 17.8
## 3 2013-07-01 3 201. 2013 NA 6 17.8
## 4 2013-07-01 4 65.9 2013 NA 6 17.8
## 5 2013-07-01 5 317. 2013 NA 6 17.8
## 6 2013-07-02 1 160. 2013 NA 3 17.3
## # ... with 2 more variables: Windgeschwindigkeit <dbl>, Wettercode <dbl>
3.5 Korrektur der Anzahl Nachkommastellen für einzelne Variablen
Die Variablen Umsatz und Temperatur enthalten jeweils vier Nachkommastellen, die als überflüssig und unsinnig erachtet werden. Die Anzahl der Nachkommstellen wird entsprechend korrigiert, wobei die Anzahl Nachkommastellen bei der Variable Umsatz auf 2 Nachkommastellen, die Variable Temperatur auf 1 Nachkommastelle gerundet wird:
df_voll <- df_voll %>%
mutate(Umsatz = round(Umsatz, 2)) %>%
mutate(Temperatur = round(Temperatur, 1))
head(df_voll)## # A tibble: 6 x 9
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2013-07-01 1 149. 2013 NA 6 17.8
## 2 2013-07-01 2 536. 2013 NA 6 17.8
## 3 2013-07-01 3 201. 2013 NA 6 17.8
## 4 2013-07-01 4 65.9 2013 NA 6 17.8
## 5 2013-07-01 5 317. 2013 NA 6 17.8
## 6 2013-07-02 1 160. 2013 NA 3 17.3
## # ... with 2 more variables: Windgeschwindigkeit <dbl>, Wettercode <dbl>
3.6 Umgang mit fehlenden Werten
Der Datensatz KiWo enthält nur 72 Datensätze: für jedes Jahr wurde den Tagen, an denen die KiWo stattfindet, eine 1 zugeordnet. Diese Werte wurden Bei der Vereinigung der Datensätze entsprechend korrekt gemerged. Für alle anderen Daten, an denen keine KiWo ist, wurde bei der Vereinigung ein fehlender Wert (NA) automatisch erzeugt. Diese fehlenden Werte sind für die weitergehenden Analysen durch “0” zu ersetzen:
## # A tibble: 6 x 9
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2013-07-01 1 149. 2013 0 6 17.8
## 2 2013-07-01 2 536. 2013 0 6 17.8
## 3 2013-07-01 3 201. 2013 0 6 17.8
## 4 2013-07-01 4 65.9 2013 0 6 17.8
## 5 2013-07-01 5 317. 2013 0 6 17.8
## 6 2013-07-02 1 160. 2013 0 3 17.3
## # ... with 2 more variables: Windgeschwindigkeit <dbl>, Wettercode <dbl>
Da die Variable Wettercode vglw. viele fehlende Werte hat (669) und unklar ist, wie diese fehlenden Werte sinnvoll ersetzt werden können, wird diese Variable ignoriert und eliminiert:
## # A tibble: 6 x 8
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2013-07-01 1 149. 2013 0 6 17.8
## 2 2013-07-01 2 536. 2013 0 6 17.8
## 3 2013-07-01 3 201. 2013 0 6 17.8
## 4 2013-07-01 4 65.9 2013 0 6 17.8
## 5 2013-07-01 5 317. 2013 0 6 17.8
## 6 2013-07-02 1 160. 2013 0 3 17.3
## # ... with 1 more variable: Windgeschwindigkeit <dbl>
3.7 Ergänzung um die Variablen Wochentag, Monat und Jahr
Ein wesentlicher Einflussfaktor für die Umsatzprognose wird der Wochentag sein, wir fügen diesen als eigene Spalte hinzu: Sonntag (1), Montag (2), … , Samstag (7). Und für die spätere Aufteilung der Daten in Training- und Testset wird das Jahr als weitere Spalte ergänzt und der Monat.
Damit die Wochentage adäquat in die späteren Modelle einfließen können, wird der Wochentag überdies als character-Variable abgespeichert.
Bsp.: Soll der Wochentag ein lineare Regressionsmodell aufgenommen werden, würde eine numerische Variable zu falschen Ergebnissen führen (wird der Wochentag um eins erhöht, erhöht sich der Umsatz um xy%). Bei einer character-Variable würde diese “dummyfiziert”. Ein Wochentag würde als Referenztag abgebildet werden und die anderen 6 Wochentage in Form von Dummyvariablen.
df_voll <- df_voll %>% mutate(Wochentag = wday(Datum))
df_voll <- df_voll %>% mutate(Jahr = year(Datum))
df_voll <- df_voll %>% mutate(Monat = month(Datum))
# Wochentag als character-Variable
df_voll <- df_voll %>% mutate(Wochentag_c = recode(Wochentag, "1" = "Sonntag", "2" = "Montag", "3" = "Dienstag", "4" = "Mittwoch", "5" = "Donnerstag", "6" = "Freitag", "7" = "Samstag"))
# Monat als character-Variable
df_voll <- df_voll %>% mutate(Monat_c = recode(Monat, "1" = "Januar", "2" = "Februar", "3" = "März", "4" = "April", "5" = "Mai", "6" = "Juni", "7" = "Juli", "8" = "August", "9" = "September", "10" = "Oktober", "11" = "November", "12" = "Dezember"))Es besteht die Möglichkeit, dass es unterhalb der Wochentag keine großen Unterschiede gibt, wohl aber zwischen Wochentagen und Wochenendtagen. Insofern wird eine weitere Variable Wochenende erstellt, die nur die beiden Ausprägungen 1 = “Wochenende” und 0 = “kein Wochenende” (“Wochentag”) hat.
3.8 Ergänzung um Sommerferienvariablen
Die Sommerferien scheinen einen starken Einfluss auf den Umsatz zu haben. Für die anderen Ferienzeiträume des Jahres gilt dies nicht. Für ausgewählte Bundesländer, namentlich Schleswig-Holstein, Nordrhein-Westfalen, Niedersachsen und Hessen wurden daher zunächst Datensätze in Excel erstellt (1 Datensatz je Bundesland). Diese Datensätze enthalten die Zeiträume der Sommerferien über die einzelnen Jahre. Diese Datensätze werden in R eingelesen und mit den anderen Daten zusammengeführt.
Die Auswahl der genannten Bundesländer erfolgte dabei anhand der Besucherzahlen / Übernachtungsvolumina in den vergangenen Jahren. Die meisten Gäste in Schleswig-Holstein kommen aus NRW, gefolgt von Niedersachsen und Schleswig-Holstein. Die Besucherzahlen aus Hessen lagen in den vergangenen Jahren etwas unterhalb derer von Niedersachsen und Schleswig-Holstein. Für Bayern und Baden-Württemberg werden zwar für die nähere Zukunft große Wachstumspotentiale prognostiziert, die Volumina waren in den betrachteten Zeiträumen jedoch gering und können daher vernachlässigt werden. Ebenso vernachlässigbar sind die übrigen Bundesländer.
## Ergänzung der Sommerferien Schleswig-Holstein
SoFeSH <- read_csv2("data/SoFe_SH.csv") # da der Separator ein ";" ist, muss read_csv2 verwendet werden
df_voll <- left_join(df_voll, SoFeSH, by = "Datum")
# Beim mergen erzeugte fehlende Werte (NA) durch 0 ersetzen:
df_voll <- df_voll %>%
mutate(SommerferienSH = replace_na(SommerferienSH, 0))
## Ergänzung der Sommerferien Nordrhein-Westfalen
SoFeNRW <- read_csv2("data/SoFe_NRW.csv")
df_voll <- left_join(df_voll, SoFeNRW, by = "Datum")
# Beim mergen erzeugte fehlende Werte (NA) durch 0 ersetzen:
df_voll <- df_voll %>%
mutate(SommerferienNRW = replace_na(SommerferienNRW, 0))
## Ergänzung der Sommerferien Niedersachsen
SoFeNDS <- read_csv2("data/SoFe_NDS.csv")
df_voll <- left_join(df_voll, SoFeNDS, by = "Datum")
# Beim mergen erzeugte fehlende Werte (NA) durch 0 ersetzen:
df_voll <- df_voll %>%
mutate(SommerferienNDS = replace_na(SommerferienNDS, 0))
# Ergänzung der Sommerferien Hessen
SoFeHE <- read_csv2("data/SoFe_HE.csv")
df_voll <- left_join(df_voll, SoFeHE, by = "Datum")
# Beim mergen erzeugte fehlende Werte (NA) durch 0 ersetzen:
df_voll <- df_voll %>%
mutate(SommerferienHE = replace_na(SommerferienHE, 0))3.10 Ergänzung um Variable Jahreszeit
Die ersten Betrachtungen und Analysen lassen darauf schließen, dass die Jahreszeiten einen Einfluss auf die Höhe des Umsatzes haben.
Die Variable Jahreszeiten kann bzw. muss dabei differenziert betrachtet werden. Zum einen besteht die Möglichkeit, Jahreszeiten als vorgegebene bzw. eigens definierte Variablen abzubilden. Dabei kann man bspw. den astronomische Eigenschaften zugrunde legen. Andererseits gibt es Modelle, die von sich heraus aus fiktive bzw. synthetische Jahreszeiten im Hintergrund ableiten.
Bsp.: Jahreszeiten können im Rahmen eines Entscheidungsbaums derart generiert werden, dass März, April, Mai zusammengefasst werden und zusätzlich aufgrund struktureller Ähnlichkeiten der September und der Oktober zu dieser (synthetischen) Jahreszeit hinzugefügt werden.
Die erste Möglichkeit soll an dieser Stelle umgesetzt werden. Die zweite Möglichkeit wird im weiteren Verlauf bei der Anwendung der unterschiedlichen Modelle relevant sein.
Anlegen einer eigens definierten Jahreszeit-Variable
Grundsätzlich unterteilen die Jahreszeiten das Jahr in verschiedene Perioden, welche sich durch charakteristische astronomische oder klimatische Eigenschaften auszeichnen. Im alltäglichen Sprachgebrauch sind damit hauptsächlich meteorologisch deutlich voneinander unterscheidbare Jahresabschnitte gemeint; in gemäßigten Breiten sind dies Frühling, Sommer, Herbst und Winter. (http://www.hrhen.de/wk/html/jahreszeiten.html, https://vschweiz.ch/jahreszeitenbeginn/)
Legt man astronomische Jahreszeitenanfänge für die Erstellung einer ersten Jahreszeit-Variable zugrunde, sind folgende Daten zu berücksichtigen:
| Jahr | Frühling | Sommer | Herbst | Winter |
|---|---|---|---|---|
| 2013 | 20. März | 21. Juni | 22. September | 21. Dezember |
| 2014 | 20. März | 21. Juni | 23. September | 22. Dezember |
| 2015 | 20. März | 21. Juni | 23. September | 22. Dezember |
| 2016 | 20. März | 21. Juni | 22. September | 21. Dezember |
| 2017 | 20. März | 21. Juni | 22. September | 21. Dezember |
| 2018 | 20. März | 21. Juni | 23. September | 21. Dezember |
| 2019 | 20. März | 21. Juni | 23. September | 22. Dezember |
Es gibt wiederum zwei Möglichkeiten, die Variable anzulegen:
- Anlegen einer Variable mit allen Jahreszeiten
- Je eine Variable pro Jahreszeit
Zunächst wird eine Variable für alle Jahreszeiten erstellt bzw. eingelesen und an den bestehenden Rohdatensatz hinzugefügt:
## Hinzufügen der Variable Jahreszeiten
Jahreszeiten <- read_csv2("data/Jahreszeiten.csv")
df_voll <- left_join(df_voll, Jahreszeiten, by = "Datum")In einem weiteren Schritt werden für die einzelnen Jahreszeiten eigene Variablen angelegt und mit dem bestehenden Rohdatensatz verknüpft:
## Hinzufügen der Variable Fruehling
Fruehling <- read_csv2("data/Fruehling.csv")
df_voll <- left_join(df_voll, Fruehling, by = "Datum")
# Beim mergen erzeugte fehlende Werte (NA) durch 0 ersetzen:
df_voll <- df_voll %>%
mutate(Fruehling = replace_na(Fruehling, 0))
## Hinzufügen der Variable Sommer
Sommer <- read_csv2("data/Sommer.csv")
df_voll <- left_join(df_voll, Sommer, by = "Datum")
# Beim mergen erzeugte fehlende Werte (NA) durch 0 ersetzen:
df_voll <- df_voll %>%
mutate(Sommer = replace_na(Sommer, 0))
## Hinzufügen der Variable Herbst
Herbst <- read_csv2("data/Herbst.csv")
df_voll <- left_join(df_voll, Herbst, by = "Datum")
# Beim mergen erzeugte fehlende Werte (NA) durch 0 ersetzen:
df_voll <- df_voll %>%
mutate(Herbst = replace_na(Herbst, 0))
## Hinzufügen der Variable Winter
Winter <- read_csv2("data/Winter.csv")
df_voll <- left_join(df_voll, Winter, by = "Datum")
# Beim mergen erzeugte fehlende Werte (NA) durch 0 ersetzen:
df_voll <- df_voll %>%
mutate(Winter = replace_na(Winter, 0))3.11 vollständige Datenreihe, Imputationen, Trainingsdaten, Testdaten
vollständige Datenreihe
Ergebnis der vorangegegangenen Operationen ist der Datensatz df_voll, der eine vollständige Zeitreihe vom 01.07.2013 bis 31.07.2019 für die Warengruppen 1 bis 5 enthält, angereichert um zahlreiche Variablen wir Kieler Woche, Wetterdaten, Sommerferien, Feiertage.
In diesem Datensatz fehlen teilweise die Umsätze für einzelne Tage und/oder Warengruppen, weil die Rohdaten fehlende Werte aufweisen.
Der Datensatz df_voll kann für einzelne Analysen ohne Weiteres verwendet werden, z.B. für eine Regressionsanalyse. Möchte man Vorhersagen auf Basis der Vorwochenwerte durchführen, z.B. die Umsatz-Prognose für den aktuellen Montag auf Basis des vorangegangenen Montags durchführen, könnten Probleme auftreten, da der Vorwochenwert aufgrund der unterbrochenenen Zeitreihe ggf. nicht verfügbar ist.
Imputation: Ergänzung fehlender Werte
Fehlende Daten sind im Datensatz df_voll mit NA gefüllt. Das bereitet für die Anwendung u.a. der naiven Modelle Probleme: Wenn bspw. der Umsatz auf Basis des Vorwochenwertes geschätzt werden soll, dann wird ein “sinnvoller” Umsatz für jedes Datum erwartet.
Zuerst kennzeichnen wir im Datensatz df_voll die Zeilen, die fehlende Umsatzwerte aufweisen mit einem neuen Attribut “Umsatz_NA”, das die Werte TRUE (Umsatz fehlt in den Rohdaten und wurde ergänzt) und FALSE (Umsatz vorhanden in den Rohdaten) annimmt.
Danach wollen wir diese fehlenden Umsätze durch Werte aus der Vergangenheit ersetzen. In der Regel gucken wir uns die Umsätze der Vorwoche an dem entsprechenden Wochentag an. Eine Ausnahme machen wir für die fehlenden Umsätze an Silvester und Neujahr: Da die Vorwochenwerte erhöht sind (Heiligabend) bzw. fehlen, gehen wir 4 Wochen zurück, weil die ersetzten Werte dann als Schätzer bspw. für die Folgewoche verwendet werden sollen.
# ergänze Attribut Umsatz_NA
df_voll <- df_voll %>% mutate(Umsatz_NA=is.na(Umsatz))
# Ergänze Spalten für den Umsatz vor 1 Woche (Umsatz_lag_1W), 2 Wochen (Umsatz_lag_2W), 3 Wochen (Umsatz_lag_3W) und 4 Wochen (Umsatz_lag_4W).
# WICHTIG: Pro Woche müssen wir 7*5=35 Datensätze zurück gehen (7 Tage mal 5 Warengruppen)
df_voll <- df_voll %>% mutate(Umsatz_lag_1W=lag(Umsatz,n=35))
df_voll <- df_voll %>% mutate(Umsatz_lag_2W=lag(Umsatz,n=2*35))
df_voll <- df_voll %>% mutate(Umsatz_lag_3W=lag(Umsatz,n=3*35))
df_voll <- df_voll %>% mutate(Umsatz_lag_4W=lag(Umsatz,n=4*35))Fehlende Umsätze (Umsatz_NA = TRUE) werden dann ersetzt durch den Vorwochenwert (Umsatz_lag_1W). Falls der Wert ebenfalls fehlt, gehen wir 2 Wochen zurück (Umsatz_lag_2W). Und falls der Wert ebenfalls fehlt, gehen wir 3 Wochen zurück (Umsatz_lag_3W). Eine Ausnahme bilden Silvester und Neujahr (Silvester_ext=1): In diesem Fall wollen wir den fehlenden Umsatz aus dem Wert vor 4 Wochen nehmen (Umsatz_lag_4W).
Der ersetzte Wert wird in einer separaten Variable “Umsatz_lag” gespeichert:
# Ergänze Attribut Umsatz_lag für den Vorwochen-Umsatz mit Initialwert 0.
df_voll <- df_voll %>% mutate(Umsatz_lag = 0)
# nicht Silvester / Neujahr: Dann nehme Umsatz der Vorwoche
df_voll <- df_voll %>% mutate(Umsatz_lag_temp = Umsatz_lag_1W * Umsatz_NA * !Silvester_ext)
# Zwischenschritt: ersetze NA durch 0
df_voll <- df_voll %>%
mutate(Umsatz_lag_temp = replace_na(Umsatz_lag_temp, 0))
# Summiere Umsatz_lag und Umsatz_lag_temp
df_voll <- df_voll %>% mutate(Umsatz_lag = Umsatz_lag + Umsatz_lag_temp)
# Silvester / Neujahr: Dann nehme Umsatz von vor 4 Wochen
df_voll <- df_voll %>% mutate(Umsatz_lag_temp = Umsatz_lag_4W * Umsatz_NA * Silvester_ext)
# Zwischenschritt: ersetze NA durch 0
df_voll <- df_voll %>%
mutate(Umsatz_lag_temp = replace_na(Umsatz_lag_temp, 0))
# Summiere Umsatz_lag und Umsatz_lag_temp
df_voll <- df_voll %>% mutate(Umsatz_lag = Umsatz_lag + Umsatz_lag_temp)
# prüfe: Wo fehlte noch Umsatz in den Rohdaten (Umsatz_NA = TRUE) den wir nicht ersetzen konnten aus Umsatz_lag_1W und Umsatz_lag_4W (Umsatz_lag = 0)? und Umsatz_lag = 0?
df_voll %>% filter(Umsatz_NA & (Umsatz_lag==0))## # A tibble: 3 x 39
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2013-08-05 4 NA 2013 0 0 25.8
## 2 2014-12-25 4 NA 2014 0 7 3.1
## 3 2014-12-26 4 NA 2014 0 6 0
## # ... with 32 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_lag_temp <dbl>
# Nehme für diese Fälle den Umsatz vor 2 Wochen (Umsatz_lag_2W)
df_voll <- df_voll %>% mutate(Umsatz_lag_temp = Umsatz_lag_2W * (df_voll$Umsatz_NA & df_voll$Umsatz_lag == 0))
# Zwischenschritt: ersetze NA durch 0
df_voll <- df_voll %>%
mutate(Umsatz_lag_temp = replace_na(Umsatz_lag_temp, 0))
# Summiere Umsatz_lag und Umsatz_lag_temp
df_voll <- df_voll %>% mutate(Umsatz_lag = Umsatz_lag + Umsatz_lag_temp)
# prüfe: Wo fehlte noch Umsatz in den Rohdaten (Umsatz_NA = TRUE), der nicht ersetzt werden konnte (Umsatz_lag = 0)?
df_voll %>% filter(Umsatz_NA & (Umsatz_lag==0))## # A tibble: 0 x 39
## # ... with 39 variables: Datum <date>, Warengruppe <dbl>, Umsatz <dbl>,
## # Jahr <dbl>, KielerWoche <dbl>, Bewoelkung <dbl>, Temperatur <dbl>,
## # Windgeschwindigkeit <dbl>, Wochentag <dbl>, Monat <dbl>,
## # Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_lag_temp <dbl>
Führe nun den Umsatz aus den Rohdaten (Umsatz) zusammen mit den aus den Vorwochen ermittelten fehlenden Werten (Umsatz_lag).
Trainings- und Testdaten
Wir verwenden den Zeitraum 2014 bis 2017 als Trainingsdaten. Die Daten des Jahres 2018 dienen als Testdaten. Dafür werden weitere Datensätze erstellt. Die Datensätze df_train und df_test basieren auf dem vollstängigen Datensatz df_voll. Der vollständige Datensatz enthält die komplette Zeitreihe vom 01.07.2013 bis 31.07.2019, jedes Datum und jede Warengruppe ist enthalten. Eventuell fehlende Umsätze sind aus den Vorwochen ergänzt. Zeilen, bei denen der Umsatz ergänzt wurden, sind erkennbar am Attribut “Umsatz_NA”, die TRUE ist, wenn in den Rohdaten der Umsatz fehlte.
4 Deskriptive Analysen
4.1 Umsatz je Wochentag / Warengruppe
Untersuche den Umsatz je Wochentag und/oder Warengruppe in den Daten. Als Basis verwenden wir die zunächst den vollständigen Datensatz df_voll.
## # A tibble: 5 x 2
## Warengruppe Umsatz_sum
## <dbl> <dbl>
## 1 1 277596.
## 2 2 890675.
## 3 3 370967.
## 4 4 192355.
## 5 5 617014.
## # A tibble: 7 x 2
## Wochentag_c Umsatz_sum
## <chr> <dbl>
## 1 Dienstag 304703.
## 2 Donnerstag 315295.
## 3 Freitag 318081.
## 4 Mittwoch 303614
## 5 Montag 313530.
## 6 Samstag 390812.
## 7 Sonntag 402571.
## # A tibble: 35 x 3
## # Groups: Warengruppe [5]
## Warengruppe Wochentag_c Umsatz_sum
## <dbl> <chr> <dbl>
## 1 1 Dienstag 38815.
## 2 1 Donnerstag 44083.
## 3 1 Freitag 41408.
## 4 1 Mittwoch 37845
## 5 1 Montag 43193.
## 6 1 Samstag 47593.
## 7 1 Sonntag 24659.
## 8 2 Dienstag 112113.
## 9 2 Donnerstag 115419.
## 10 2 Freitag 117023.
## # ... with 25 more rows
## # A tibble: 35 x 3
## # Groups: Warengruppe [5]
## Warengruppe Wochentag Umsatz_sum
## <dbl> <dbl> <dbl>
## 1 1 1 24659.
## 2 1 2 43193.
## 3 1 3 38815.
## 4 1 4 37845
## 5 1 5 44083.
## 6 1 6 41408.
## 7 1 7 47593.
## 8 2 1 168796.
## 9 2 2 114975.
## 10 2 3 112113.
## # ... with 25 more rows
## # A tibble: 10 x 3
## # Groups: Warengruppe [5]
## Warengruppe Wochenende Umsatz_sum
## <dbl> <dbl> <dbl>
## 1 1 0 205343.
## 2 1 1 72252.
## 3 2 0 570332.
## 4 2 1 320343.
## 5 3 0 236159.
## 6 3 1 134809.
## 7 4 0 123959.
## 8 4 1 68396.
## 9 5 0 419431.
## 10 5 1 197583.
- Warengruppe 2 zeigt den höchsten Umsatz insgesamt, gefolgt von Warengruppe 5.
- Die Wochentage Samstag und Sonntag sind mit leichtem Abstand die umsatzstärksten Tage, aggregiert über alle Warengruppen.
- Für die einzelnen Warengruppen zeigt sich ein differenzierteres Bild: Für Brot (Warengruppe 1) sind bspw. Donnerstag und Samstag die umsatzstärksten Wochentage. Auch der Montag ist in dieser Woche überdurchschnittlich stark im Vergleich zu den anderen Warengruppen.
- Vergleicht man die Wochenendumsätze mit den Umsätzen der Wochentag, so ergibt sich folgendes Bild:
- 26% der Umsätze der Warengruppe 1 (Brot) werden am Wochenende erzielt, 74% an den Wochentagen
- 36% der Umsätze der Warengruppe 2 (Brötchen) werden am Wochenende erzielt, 64% unter der Woche.
- 37% der Umsätze der Warengruppe 3 (Croissants) werden am Wochenende erzielt, 63% an den Wochentagen.
- 36% der Umsätze der Warengruppe 4 (Konditorei) werden am Wochenende erzielt, 64% unter der Woche.
- 32% der Umsätze der Warengruppe 5 (Kuchen) werden am Wochenende erzielt, 68% unter der Woche. ==> demnach scheint es für die einzelnen Warengruppen abweichende Wochenend-Effekte geben. Kuchen und Brot werden im Verhältnis zu den anderen Warengruppen am Wochenende weniger verkauft.
4.2 Umsatz je Monat / Warengruppe
In einem weiteren Schritt werden die Umsätze je Warengruppe und Monat untersucht, um eine differenziertere Verteilung der Umsätze im Jahresverlauf zu erhalten.
## # A tibble: 60 x 3
## # Groups: Warengruppe [5]
## Warengruppe Monat Umsatz_sum
## <dbl> <dbl> <dbl>
## 1 1 1 20130.
## 2 1 2 18439.
## 3 1 3 22556.
## 4 1 4 23667.
## 5 1 5 22545
## 6 1 6 24037.
## 7 1 7 31048.
## 8 1 8 27465.
## 9 1 9 22756.
## 10 1 10 22876.
## # ... with 50 more rows
## # A tibble: 60 x 3
## # Groups: Warengruppe [5]
## Warengruppe Monat_c Umsatz_sum
## <dbl> <chr> <dbl>
## 1 1 Juli 31048.
## 2 1 August 27465.
## 3 1 Juni 24037.
## 4 1 April 23667.
## 5 1 Oktober 22876.
## 6 1 September 22756.
## 7 1 März 22556.
## 8 1 Mai 22545
## 9 1 Dezember 21791.
## 10 1 November 20284.
## # ... with 50 more rows
- Es gibt erkennbare Unterschiede zwischen den Warengruppen, was den Umsatz pro Monat anbelangt:
- In den Warengruppen 1 - 3 (und mit Einschränkung Warengruppe 5) sind die Monate Juli, August und Juni die Top 3-Monate sind,
- Bei Warengruppe 4 liegen diese Monate auf den Plätzen 3 (August), 6 (Juli) und 11 (Juni). In dieser Waregngruppe ist der Februar der umsatzstärkste Monat, gefolgt von Oktober, der bei den anderen WG eher im Mittelfeld liegt (Platz 4 - 6). Die Warengruppe 4 verhält sich bei der Verteilung der Umsätze im Monatsverlauf also deutlich anders als die anderen Warengruppen.
- Tendenziell sind die Umsätze in den Wintermonaten (Dezember, Januar, Februar) sowie im November am schwächsten (auch hier mit leichten Abweichungen bei Warengruppe 4 und 5). Die Warengruppen Konditorei und Kuchen unterscheiden sich hier, mal mehr mal weniger, von den ersten drei Warengruppen.
4.3 Umsatz im Zeitverlauf
Von Interesse ist nun die Entwicklung der Umsätze im Zeitverlauf. Wir wollen prüfen, ob eine Trendentwicklung zu beobachten ist und ob es strukturelle Brüche in den Zeitreihen gibt. Wir betrachten dafür zunächst die Entwicklung des Gesamtumsatzes pro Jahr. Als Datenbasis verwenden wir die Trainingsdaten df_train, die den Zeitraum 2014 bis 2017 umfassen und damit 4 Jahresscheiben abbilden.
## # A tibble: 4 x 2
## Jahr Umsatz
## <dbl> <dbl>
## 1 2014 428295.
## 2 2015 378659
## 3 2016 359157.
## 4 2017 356290.
Zu beobachten ist, dass der Jahresumsatz von 2014 bis 2016 sukzessive sinkt und dann 2017 stabil bleibt. Um diese Beobachtung besser zu verstehen, betrachten wir den Umsatz nun auf Monatsebene, immer noch aggregiert über alle Warengruppen.
umsatz_jahr_monat <- df_train %>% mutate(Jahr=as.character(Jahr)) %>% group_by(Jahr, Monat) %>% summarise(Umsatz=sum(Umsatz)) # Variable Jahr in character umgewandelt, damit im folgenden Plot eine diskrete Farbskala in der Legende gezeigt werden kann
p_umsatz_jahr_monat <- ggplot(data = umsatz_jahr_monat, aes(x = Monat, y = Umsatz)) +
geom_point(aes(color = Jahr), size = 3, alpha = 0.5) +
geom_line(aes(group = Jahr, color = Jahr)) +
scale_x_discrete(limits=c("1","2","3","4","5","6","7","8","9","10","11","12")) +
xlab("Monat") + ylab("Umsatz") +
labs(color = "Jahr") +
theme_classic() +
ggtitle("Gesamtumsatz je Monat")
p_umsatz_jahr_monatBeobachtungen:
- Die Jahre 2016 und 2017 sind weitestgehend ähnlich im Jahresverlauf.
- Die Umsätze im Jahr 2014 sind insgesamt offenbar parallel verschoben und systematisch höher jeden Monat.
- Und der Verlauf für 2015 ist ähnlich zu 2016 und 2017, nur in den ersten 3 Monaten des Jahres scheint der Umsatz 2015 systematisch höher zu liegen.
Um dies weiter zu analysieren, betrachten wir schließlich noch den Umsatz auf Monatsebene je Warengruppe, um eventuelle Unterschiede im Verhalten der einzelnen Warengruppen aufzudecken.
Erstellung der Variablen Umsatz auf Monatsebene Warengruppe 1
p_umsatz_jahr_monat_WG1 <-
umsatz_jahr_monat_WG %>%
filter(Warengruppe == 1) %>%
ggplot(aes(x = Monat, y = Umsatz)) +
geom_point(aes(color = Jahr), size = 3, alpha = 0.5) +
geom_line(aes(group = Jahr, color = Jahr)) +
scale_x_discrete(limits=c("1","2","3","4","5","6","7","8","9","10","11","12")) +
xlab("Monat") + ylab("Umsatz") +
labs(color = "Jahr") +
theme_classic() +
ggtitle("Warengruppe 1: Umsatz je Monat")Erstellung des Plots zur Variablen Umsatz auf Monatsebene Warengruppe 2
p_umsatz_jahr_monat_WG2 <-
umsatz_jahr_monat_WG %>%
filter(Warengruppe == 2) %>%
ggplot(aes(x = Monat, y = Umsatz)) +
geom_point(aes(color = Jahr), size = 3, alpha = 0.5) +
geom_line(aes(group = Jahr, color = Jahr)) +
scale_x_discrete(limits=c("1","2","3","4","5","6","7","8","9","10","11","12")) +
xlab("Monat") + ylab("Umsatz") +
labs(color = "Jahr") +
theme_classic() +
ggtitle("Warengruppe 2: Umsatz je Monat")Erstellung des Plots zur Variablen Umsatz auf Monatsebene Warengruppe 3
p_umsatz_jahr_monat_WG3 <-
umsatz_jahr_monat_WG %>%
filter(Warengruppe == 3) %>%
ggplot(aes(x = Monat, y = Umsatz)) +
geom_point(aes(color = Jahr), size = 3, alpha = 0.5) +
geom_line(aes(group = Jahr, color = Jahr)) +
scale_x_discrete(limits=c("1","2","3","4","5","6","7","8","9","10","11","12")) +
xlab("Monat") + ylab("Umsatz") +
labs(color = "Jahr") +
theme_classic() +
ggtitle("Warengruppe 3: Umsatz je Monat")Erstellung des Plots zur Variablen Umsatz auf Monatsebene Warengruppe 4
p_umsatz_jahr_monat_WG4 <-
umsatz_jahr_monat_WG %>%
filter(Warengruppe == 4) %>%
ggplot(aes(x = Monat, y = Umsatz)) +
geom_point(aes(color = Jahr), size = 3, alpha = 0.5) +
geom_line(aes(group = Jahr, color = Jahr)) +
scale_x_discrete(limits=c("1","2","3","4","5","6","7","8","9","10","11","12")) +
xlab("Monat") + ylab("Umsatz") +
labs(color = "Jahr") +
theme_classic() +
ggtitle("Warengruppe 4: Umsatz je Monat")Erstellung des Plots zur Variablen Umsatz auf Monatsebene Warengruppe 5
p_umsatz_jahr_monat_WG5 <-
umsatz_jahr_monat_WG %>%
filter(Warengruppe == 5) %>%
ggplot(aes(x = Monat, y = Umsatz)) +
geom_point(aes(color = Jahr), size = 3, alpha = 0.5) +
geom_line(aes(group = Jahr, color = Jahr)) +
scale_x_discrete(limits=c("1","2","3","4","5","6","7","8","9","10","11","12")) +
xlab("Monat") + ylab("Umsatz") +
labs(color = "Jahr") +
theme_classic() +
ggtitle("Warengruppe 5: Umsatz je Monat")Beobachtungen:
- Für die Warengruppen 1, 2, 3 und 5 zeigen sich ähnliche Effekte: Die Umsätze 2014 liegen systematisch höher. Das setzt sich bis in die ersten 3 Monate des Jahres 2015 fort. Ab April 2015 sind die Verläufe ähnlich bis Ende 2017.
- Die Warengruppe 4 ist insgesamt die umsatzschwächste Gruppe. Die Monatsumsätze sind über die Jahre 2014 bis 2017 relativ ähnlich. Eine Ausnahme bildet der Februar 2017: Hier liegen die Umsätze deutlich unter den Umsätzen der übrigen Jahre. Dafür gibt es bislang keine Erklärung.
Für die weitere Entwicklung unserer Prognosemodelle könnte es daher sinnvoll sein, dass wir uns bei den Trainingsdaten auf den Zeitraum ab April 2015 bis 2017 beschränken und die Zeit davor außer Acht lassen. Und wir behalten im Hinterkopf, dass der Februar 2017 auffällig niedrige Umsätze aufweist.
5 Anwendung naiver Modelle
5.1 Vorhaben
Wir wollen nun einige naive Modelle einsetzen, um die Umsätze je Warengruppe zu prognostizieren. Wir arbeiten dafür mit dem vollständigen Datensatz df_voll, der für jeden Tag und jede Warengruppe eine Zeile enthält. Fehlende Umsatzwerte in den Rohdaten sind durch die Vorwochenwerte ersetzt, weitere fehlenden Daten sind mit NA gefüllt.
Wir werden im folgenden verschiedene naive Prognosemodelle testen und vergleichen. Zuerst betrachten wir die Schätzung des Umsatzes auf Basis des Vorwochenwertes (Umsatz_lag_1W).
Im zweiten Teil betrachten wir die Schätzung mittels eines gleitenden Durchschnitts über die letzten 3 Tage (Umsatz_glDS_3T). Wir wissen bereits, dass der Umsatz am Wochenende systematisch höher ist, als unter der Woche. Daher erwarten wir, dass der gleitende Durchschnitt in der Form nur eingeschränkt geeignet ist, wahrscheinlich nur Für Donnerstag und Freitag. Als Erweiterung könnte man den Umsatz für Wochentage auf Basis des Durchschnitts der letzten drei Wochentage schätzen und den Umsatz für Wochenendtage auf Basis der letzten drei Wochenendtage (Umsatz_glDS_3T_erw), oder sogar auf Basis der letzten vier Wochentage bzw. Wochenendtage (Umsatz_glDS_4T_erw).
Und schließlich betrachten wir einen gewichteten Mittelwert der Vorwochen (Umsatz_gewMW_4W) als Schätzer. Hierbei gewichten wir den Wert der Vorwoche mit 50%, den Wert zwei Wochen zurück mit 25% und den Wert drei Wochen zurück mit 15% und den Wert vier Wochen zurück mit 10%.
Dann werfen wir einen Blick auf die Prognose-Güte:
- Anteil an zu hoch / zu niedrig geschätzten Umsätze, ggf. je Warengruppe und/oder Wochentag
- mittlere Abweichung, mittlere absolute Abweichung, mittlere quadratische Abweichung
- Standardabweichung, Verteilung der Abweichungen
Wir wollen die naiven Modelle in ihrer Prognose-Güte vergleichen. Weiterhin prüfen wir die Top10 stärksten Abweichungen nach oben und nach unten für die verschiedenen Modelle, um rauszufinden, ob es Tage gibt, für die mehrere oder sogar alle naiven Modelle versagen.
5.2 Datenaufbereitung
Wir arbeiten mit dem vollständigen Datensatz df_voll. Dieser enthält im Zeitraum 01.07.2013 bis 31.07.2019 eine Zeile für jedes Datum und jede Warengruppe. In den Rohdaten fehlende Umsätze sind auf Basis der Vorwochenwerte ergänzt worden. Die Zeilen mit ergänzten Umsätzen sind selektierbar über die Variable Umsatz_NA (= TRUE).
Zunächst benötigen wir Werte für folgende Attribute, die teilweise schon vorhanden sind und teilweise neu erstellt werden:
- Umsatz_lag_1W
- Umsatz_lag_2W
- Umsatz_lag_3W
- Umsatz_lag_4W
- Umsatz_gewMW_4W
- Umsatz_lag_1T bis Umsatz_lag_8T, Umsatz_lag_13T, Umsatz_lag_14T (1 bis 8, 13 und 14 Tage zurück)
- Umsatz_glDS_3T
- Umsatz_glDS_3T_erw
- Umsatz_glDS_4T_erw
Wir erstellen für diesen Abschnitt einen Analysedatensatz df_naiv auf Basis von df_voll.
# initialisiere Datensatz
df_naiv <- df_voll
# fülle Umsatz_lag_1W mit dem Vorwochenwert (also 7 Tage mal 5 Warengruppen zurück)
df_naiv <- df_naiv %>% mutate(Umsatz_lag_1W = lag(Umsatz, n=35))
# fülle entsprechend Umsatz_lag_2W, Umsatz_lag_3W, Umsatz_lag_4W
df_naiv <- df_naiv %>% mutate(Umsatz_lag_2W = lag(Umsatz, n=70))
df_naiv <- df_naiv %>% mutate(Umsatz_lag_3W = lag(Umsatz, n=105))
df_naiv <- df_naiv %>% mutate(Umsatz_lag_4W = lag(Umsatz, n=140))
# damit können wir bereits den gewichteten Mittelwert der letzten 4 Wochen erstellen
df_naiv <- df_naiv %>% mutate(Umsatz_gewMW_4W = 0.5*Umsatz_lag_1W + 0.25*Umsatz_lag_2W + 0.15*Umsatz_lag_3W + 0.1 * Umsatz_lag_4W)
# Bereite die Berechnung des gleitenden Durchschnitts der letzten 3 Tage vor.
# Für die Berechnung des erweiterten gleitenden Durchschnitts benötigen wir weitere Tage.
df_naiv <- df_naiv %>% mutate(Umsatz_lag_1T = lag(Umsatz, n=5)) # 1 Tag zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_2T = lag(Umsatz, n=10)) # 2 Tage zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_3T = lag(Umsatz, n=15)) # 3 Tage zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_4T = lag(Umsatz, n=20)) # 4 Tage zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_5T = lag(Umsatz, n=25)) # 5 Tage zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_6T = lag(Umsatz, n=30)) # 6 Tage zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_7T = lag(Umsatz, n=35)) # 7 Tage zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_8T = lag(Umsatz, n=40)) # 8 Tage zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_13T = lag(Umsatz, n=65)) # 13 Tage zurück
df_naiv <- df_naiv %>% mutate(Umsatz_lag_14T = lag(Umsatz, n=70)) # 14 Tage zurück
# nun können wir den gleitenden Durchschnitt der letzten 3 Tage erstellen
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T = (Umsatz_lag_1T + Umsatz_lag_2T + Umsatz_lag_3T) / 3)
# Dir Berechnung des erweiterten gleitenden Durchschnitt ist etwas aufwändiger: Hierfür wollen wir zuerst den Durchschnitt der letzten 3 Wochentage bzw. Wochenendtage ermitteln. Für einen Montag müssen wir also 3, 4 und 5 Tage zurück gehen, für einen Samstag 6, 7 und 13 Tage. Oder anders ausgedrückt: Der Umsatz 1 Tag zurück (Umsatz_lag_1T) fließt in die Berechnung des erweiterten Durchschnitts für die Tage Di, Mi, Do, Fr und So ein, also alle Tage außer Mo und Sa. Wir errechnen den erweiterten Durchschnitt scheibenweise:
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = 0) # initialisiere neue Variable
# speichere die 1. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_1T * (df_naiv$Wochentag_c != "Montag" & df_naiv$Wochentag_c != "Samstag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# speichere die 2. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_2T * (df_naiv$Wochentag_c == "Mittwoch" | df_naiv$Wochentag_c == "Donnerstag" | df_naiv$Wochentag_c == "Freitag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# speichere die 3. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_3T * (df_naiv$Wochentag_c == "Montag" | df_naiv$Wochentag_c == "Donnerstag" | df_naiv$Wochentag_c == "Freitag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# speichere die 4. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_4T * (df_naiv$Wochentag_c == "Montag" | df_naiv$Wochentag_c == "Dienstag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# speichere die 5. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_5T * (df_naiv$Wochentag_c == "Montag" | df_naiv$Wochentag_c == "Dienstag" | df_naiv$Wochentag_c == "Mittwoch"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# speichere die 6. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_6T * (df_naiv$Wochentag_c == "Samstag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# speichere die 7. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_7T * (df_naiv$Wochentag_c == "Samstag" | df_naiv$Wochentag_c == "Sonntag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# speichere die 8. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_8T * (df_naiv$Wochentag_c == "Sonntag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# speichere die 13. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_13T * (df_naiv$Wochentag_c == "Samstag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_3T_erw, mit Faktor 1/3
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_3T_erw = Umsatz_glDS_3T_erw + (Umsatz_temp / 3))
# Prüfung: df_naiv %>% filter(is.na(Umsatz_glDS_3T_erw))# Wir wiederholen das Vorgehen, um noch den Durchschnitt der letzten 4 Wochentage bzw. Wochenendtage ermitteln. Für einen Montag müssen wir also 3, 4, 5 und 6 Tage zurück gehen, für einen Samstag 6, 7, 13 und 14 Tage. Oder anders ausgedrückt: Der Umsatz 1 Tag zurück (Umsatz_lag_1T) fließt in die Berechnung des erweiterten Durchschnitts für die Tage Di, Mi, Do, Fr und So ein, also alle Tage außer Mo und Sa. Wir errechnen den erweiterten Durchschnitt scheibenweise:
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = 0) # initialisiere neue Variable
# speichere die 1. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_1T * (df_naiv$Wochentag_c != "Montag" & df_naiv$Wochentag_c != "Samstag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 2. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_2T * (df_naiv$Wochentag_c == "Mittwoch" | df_naiv$Wochentag_c == "Donnerstag" | df_naiv$Wochentag_c == "Freitag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 3. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_3T * (df_naiv$Wochentag_c == "Montag" | df_naiv$Wochentag_c == "Donnerstag" | df_naiv$Wochentag_c == "Freitag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 4. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_4T * (df_naiv$Wochentag_c == "Montag" | df_naiv$Wochentag_c == "Dienstag" | df_naiv$Wochentag_c == "Freitag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 5. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_5T * (df_naiv$Wochentag_c == "Montag" | df_naiv$Wochentag_c == "Dienstag" | df_naiv$Wochentag_c == "Mittwoch"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 6. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_1T * (df_naiv$Wochentag_c != "Freitag" & df_naiv$Wochentag_c != "Sonntag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 7. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_7T * (df_naiv$Wochentag_c == "Samstag" | df_naiv$Wochentag_c == "Sonntag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 8. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_8T * (df_naiv$Wochentag_c == "Sonntag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 13. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_13T * (df_naiv$Wochentag_c == "Samstag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))
# speichere die 14. Scheibe in Umsatz_temp zwischen
df_naiv <- df_naiv %>% mutate(Umsatz_temp = Umsatz_lag_14T * (df_naiv$Wochentag_c == "Samstag" | df_naiv$Wochentag_c == "Sonntag"))
# Zwischenschritt: ersetze NA durch 0
df_naiv <- df_naiv %>%
mutate(Umsatz_temp = replace_na(Umsatz_temp, 0))
# übernehme das Zwischenergebnis in die Zielvariable Umsatz_glDS_4T_erw, mit Faktor 1/4
df_naiv <- df_naiv %>% mutate(Umsatz_glDS_4T_erw = Umsatz_glDS_4T_erw + (Umsatz_temp / 4))Unsere Schätzung machen wir nur für Tage, für die Umsatzdaten in den Rohdaten vorlagen (Umsatz_NA = FALSE). Und für die einzelnen Modelle beginnt die Schätzung erst ab dem Zeitpunkt, ab dem Vorwochenwerte vorliegen. Für die Verwendung des gewichteten MIttelwertes der letzten 4 Wochen können wir bspw. erst ab dem 29. Tag schätzen. Alle anderen Schätzer liegen schon früher vor. Für die Vergleichbarkeit der Modelle starten wir daher einheitlich ab dem 01.08.2013 (also sogar erst 31 Tage nach Beginn der Zeitreihe).
5.3 Prognose der Umsätze anhand des Vorwochenwertes
Für die Schätzung und die anschließende Ermittlung der Gütemaße verwenden wir einen eigenen Datensatz prog_naiv_lag_1W.
prog_naiv_lag_1W <- df_naiv %>%
filter(Umsatz_NA == FALSE) %>% # fehlende Umsätze in den Rohdaten raus nehmen
filter(Datum >= "2013-08-01") # starte ab 01.08.2013
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
prog_naiv_lag_1W <- prog_naiv_lag_1W %>%
mutate(Prognose_zuhoch = (Umsatz_lag_1W >= Umsatz)) %>%
mutate(Abweichung = Umsatz_lag_1W - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_lag_1W - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_lag_1W - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Prognosegüte: Anteil "zu hoch prognostiziert". Ergänze dafür zunächst die Anzahl der Beobachtungen je Warengruppe (Anzahl), um danach den absoluten Anteil (Anteil_abs) und relativen Anteil (Anteil_rel) zu ermitteln.
prog_naiv_lag_1W <- prog_naiv_lag_1W %>%
group_by(Warengruppe) %>%
mutate(Anzahl = n())
prog_naiv_lag_1W %>%
group_by(Warengruppe, Prognose_zuhoch) %>%
summarise(Anteil_abs = n(), Anteil_rel = round(n() / mean(Anzahl) * 100))## # A tibble: 10 x 4
## # Groups: Warengruppe [5]
## Warengruppe Prognose_zuhoch Anteil_abs Anteil_rel
## <dbl> <lgl> <int> <dbl>
## 1 1 FALSE 1059 49
## 2 1 TRUE 1086 51
## 3 2 FALSE 1054 49
## 4 2 TRUE 1091 51
## 5 3 FALSE 1061 49
## 6 3 TRUE 1084 51
## 7 4 FALSE 1023 49
## 8 4 TRUE 1075 51
## 9 5 FALSE 1060 49
## 10 5 TRUE 1085 51
# Prognosegüte: mittlere Abweichung, Standardabweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung, das 5% und das 95% Quantil für die Abweichung
prog_naiv_lag_1W %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n(), mittlUmsatz=mean(Umsatz), mittlAbw=mean(Abweichung), StdAbw=sd(Abweichung), mittlAbw_abs=mean(Abweichung_abs), mittlAbw_rel=round(mean(Abweichung_abs)/mean(Umsatz)*100), mittlAbw_quad=sum(Abweichung_quad)/n(), Abweichung_Q5 = quantile(Abweichung, probs = c(0.05)), Abweichung_Q95 = quantile(Abweichung, probs = c(0.95)))## # A tibble: 5 x 10
## Warengruppe Anzahl mittlUmsatz mittlAbw StdAbw mittlAbw_abs mittlAbw_rel
## <dbl> <int> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 2145 125. -0.0664 41.4 29.9 24
## 2 2 2145 399. 0.204 85.1 58.2 15
## 3 3 2145 166. -0.0511 45.3 32.9 20
## 4 4 2098 87.2 0.0784 32.5 23.3 27
## 5 5 2145 277. 0.354 125. 53.3 19
## # ... with 3 more variables: mittlAbw_quad <dbl>, Abweichung_Q5 <dbl>,
## # Abweichung_Q95 <dbl>
# visualisiere die relative Abweichung im Histogramm: Erhalte eine Verteilung der Abweichung
naiv_lag_1W_relAbw_hist <- ggplot(data = prog_naiv_lag_1W, aes(x = Abweichung_rel*100)) +
geom_histogram(binwidth = 5, fill="steelblue", color="black", size=0.5) +
ggtitle("Schätzung auf Basis der Vorwoche: Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Anzahl Beobachtungen")
# ermittle die Dichteverteilung für die Abweichung
naiv_lag_1W_relAbw_dens <- ggplot(data = prog_naiv_lag_1W, aes(x = Abweichung_rel*100)) +
geom_density(fill="steelblue", color="steelblue", size=0.5, alpha = 0.3) +
ggtitle("Schätzung auf Basis der Vorwoche: Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Dichte")
# zeige das Histogramm und die Dichteverteilung
naiv_lag_1W_relAbw_histDie Verteilung der relativen Abweichung erscheint sehr breit. Unser naiver Schätzer auf Basis des Vorwochenwertes liefert also keine gute Umsatzprognose. Augenscheinlich gibt es einige Prognosewerte, die deutlich zu hoch sind. Diese Ausreißer wollen wir nun näher untersuchen, um zu verstehen, an welchen Stellen unser Modell noch Probleme hat. Für die Untersuchung der Prognosegüte hatten wir den Datensatz prog_naiv_lag_1W erstellt, mit dem wir jetzt weiter arbeiten.
# Untersuche die Fälle, in denen die Prognose mehr als 100% höher war als der Umsatz. Die Ausreißer verteilen sich folgendermaßen auf die Warengruuppen:
prog_naiv_lag_1W %>%
filter(Abweichung_rel > 1) %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n())## # A tibble: 5 x 2
## Warengruppe Anzahl
## <dbl> <int>
## 1 1 46
## 2 2 11
## 3 3 19
## 4 4 53
## 5 5 9
# Offenbar haben wir ein Problem für die Warengruppen 1 (Brot) und 4 (Konditorei), die wir näher betrachen wollen. Untersuche, ob Feiertage die Ursache sind:
prog_naiv_lag_1W %>%
filter(Abweichung_rel > 1, Warengruppe == 1 | Warengruppe == 4) %>%
group_by(Warengruppe, Feiertag) %>%
summarise(Anzahl=n())## # A tibble: 3 x 3
## # Groups: Warengruppe [2]
## Warengruppe Feiertag Anzahl
## <dbl> <dbl> <int>
## 1 1 0 36
## 2 1 1 10
## 3 4 0 53
# Das liefert uns keine nennenswerten Erkenntnisse, Feiertage scheinen nicht die Hauptursache für die starken Abweichungen zu sein. Untersuche, ob einzelne Wochentage besonders betroffen sind, jetzt wieder über alle Warengruppen:
prog_naiv_lag_1W %>%
filter(Abweichung_rel > 1) %>%
group_by(Wochentag_c) %>%
summarise(Anzahl=n())## # A tibble: 7 x 2
## Wochentag_c Anzahl
## <chr> <int>
## 1 Dienstag 7
## 2 Donnerstag 25
## 3 Freitag 8
## 4 Mittwoch 20
## 5 Montag 33
## 6 Samstag 25
## 7 Sonntag 20
Für Dienstage und Freitage scheint unser naiver Schätzer nur selten eine deutlich zu hohe Prognose zu liefern. Ansonsten sind keine Unterschiede zu erkennen.
Wir werfen nun einen Blick auf die Top10 Abweichungen (Abweichung_rel) nach oben und nach unten: Für welche Tage liegt der Schätzer auf Basis des Vorwochenwertes besonders weit daneben? Oder gibt es Warengruppen, für die der Schätzer besonders viele große Ausreißer aufweist?
# sortiere nach der relativen Abweichung und zeige die ersten und letzten 10 Zeilen
prog_naiv_lag_1W %>%
arrange(Abweichung_rel) %>%
head(n=10)## # A tibble: 10 x 59
## # Groups: Warengruppe [3]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2016-12-31 5 1705. 2016 0 7 4.9
## 2 2017-12-31 5 1432. 2017 0 7 8.2
## 3 2014-12-31 5 1879. 2014 0 6 7.4
## 4 2015-12-31 5 1870. 2015 0 7 2
## 5 2013-12-31 5 1626. 2013 0 4 5
## 6 2016-02-04 4 213. 2016 0 5 4.2
## 7 2018-12-31 5 1668. 2018 0 7 7.4
## 8 2017-04-24 1 92.5 2017 0 7 8.9
## 9 2017-05-25 4 179. 2017 0 2 18.9
## 10 2016-05-16 4 221. 2016 0 5 11.2
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
## # A tibble: 10 x 59
## # Groups: Warengruppe [3]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2014-03-02 4 108. 2014 0 6 6.6
## 2 2017-01-07 1 71.7 2017 0 8 -0.5
## 3 2018-01-07 5 316. 2018 0 0 0.6
## 4 2017-04-22 1 81.4 2017 0 5 7.5
## 5 2017-01-07 5 266. 2017 0 8 -0.5
## 6 2019-01-07 5 250. 2019 0 8 5.9
## 7 2017-04-17 1 23.2 2017 0 6 6.2
## 8 2015-01-07 5 263. 2015 0 6 5.8
## 9 2014-01-07 5 211. 2014 0 7 10.4
## 10 2016-01-07 5 212. 2016 0 7 -4
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
Für Silvester liefert unser naiver Schätzer auf Basis des Vorwochenwertes offenbar systematisch zu niedrige Prognosen, besonders für Warengruppe 5 (Kuchen), was vermutlich am Verkauf der Berliner liegt. Das war zu erwarten, weil Silvester immer sehr umsatzstarke Tage sind. Ebenso liefert das Modell für den 7. Januar konsequent zu hohe Schätzwerte, weil diese auf Basis der sehr hohen Silvester-Umsätze prognostiziert werden.
5.4 Prognose der Umsätze anhand des gleitenden Durchschnitts
In diesem Abschnitt betrachten wir die Schätzung mittels eines gleitenden Durchschnitts über die letzten 3 Tage (Umsatz_glDS_3T). Wir wissen bereits, dass der Umsatz am Wochenende systematisch höher ist, als unter der Woche. Daher erwarten wir, dass der gleitende Durchschnitt in der Form nur eingeschränkt geeignet ist, wahrscheinlich nur Für Donnerstag und Freitag.
Als Erweiterung wollen wir den Umsatz für Wochentage auf Basis des Durchschnitts der letzten drei Wochentage schätzen und den Umsatz für Wochenendtage auf Basis der letzten drei Wochenendtage (Umsatz_glDS_3T_erw). Und am Ende erweitern wir dieses Vorgehen sogar noch um einen Tag (Umsatz_glDS_4T_erw) und beziehen die letzten vier Wochen- bzw. Wochenendtage in die Prognose ein.
Gleitender Durchschnitt der letzten 3 Tage
Für die Schätzung und die anschließende Ermittlung der Gütemaße verwenden wir eigene Datensätze prog_naiv_glDS_3T und prog_naiv_glDS_3T_erw bzw. prog_naiv_glDS_4T_erw. Wir starten wieder am 01.08.2013, um die Vergleichbarkeit der naiven Modelle zu wahren.
prog_naiv_glDS_3T <- df_naiv %>%
filter(Umsatz_NA == FALSE) %>% # fehlende Umsätze in den Rohdaten raus nehmen
filter(Datum >= "2013-08-01") # starte ab 01.08.2013
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
prog_naiv_glDS_3T <- prog_naiv_glDS_3T %>%
mutate(Prognose_zuhoch = (Umsatz_glDS_3T >= Umsatz)) %>%
mutate(Abweichung = Umsatz_glDS_3T - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_glDS_3T - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_glDS_3T - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Prognosegüte: Anteil "zu hoch prognostiziert". Ergänze dafür zunächst die Anzahl der Beobachtungen je Warengruppe (Anzahl), um danach den absoluten Anteil (Anteil_abs) und relativen Anteil (Anteil_rel) zu ermitteln.
prog_naiv_glDS_3T <- prog_naiv_glDS_3T %>%
group_by(Warengruppe) %>%
mutate(Anzahl = n())
prog_naiv_glDS_3T %>%
group_by(Warengruppe, Prognose_zuhoch) %>%
summarise(Anteil_abs = n(), Anteil_rel = round(n() / mean(Anzahl) * 100))## # A tibble: 10 x 4
## # Groups: Warengruppe [5]
## Warengruppe Prognose_zuhoch Anteil_abs Anteil_rel
## <dbl> <lgl> <int> <dbl>
## 1 1 FALSE 1183 55
## 2 1 TRUE 962 45
## 3 2 FALSE 1047 49
## 4 2 TRUE 1098 51
## 5 3 FALSE 1008 47
## 6 3 TRUE 1137 53
## 7 4 FALSE 938 45
## 8 4 TRUE 1160 55
## 9 5 FALSE 1065 50
## 10 5 TRUE 1080 50
# Prognosegüte: mittlere Abweichung, Standardabweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung, das 5% und das 95% Quantil für die Abweichung
prog_naiv_glDS_3T %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n(), mittlUmsatz=mean(Umsatz), mittlAbw=mean(Abweichung), StdAbw=sd(Abweichung), mittlAbw_abs=mean(Abweichung_abs), mittlAbw_rel=round(mean(Abweichung_abs)/mean(Umsatz)*100), mittlAbw_quad=sum(Abweichung_quad)/n(), Abweichung_Q5 = quantile(Abweichung, probs = c(0.05)), Abweichung_Q95 = quantile(Abweichung, probs = c(0.95)))## # A tibble: 5 x 10
## Warengruppe Anzahl mittlUmsatz mittlAbw StdAbw mittlAbw_abs mittlAbw_rel
## <dbl> <int> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 2145 125. -0.755 41.8 30.6 25
## 2 2 2145 399. -1.99 108. 86.2 22
## 3 3 2145 166. -0.767 51.6 39.8 24
## 4 4 2098 87.2 -0.197 36.6 26.0 30
## 5 5 2145 277. -2.05 99.2 49.0 18
## # ... with 3 more variables: mittlAbw_quad <dbl>, Abweichung_Q5 <dbl>,
## # Abweichung_Q95 <dbl>
# visualisiere die relative Abweichung im Histogramm: Erhalte eine Verteilung der Abweichung
naiv_glDS_3T_relAbw_hist <- ggplot(data = prog_naiv_glDS_3T, aes(x = Abweichung_rel*100)) +
geom_histogram(binwidth = 5, fill="red", color="black", size=0.5) +
ggtitle("Schätzung auf Basis des gl. Durchschnitts (3 Tage): Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Anzahl Beobachtungen")
# ermittle die Dichteverteilung für die Abweichung
naiv_glDS_3T_relAbw_dens <- ggplot(data = prog_naiv_glDS_3T, aes(x = Abweichung_rel*100)) +
geom_density(fill="red", color="red", size=0.5, alpha = 0.3) +
ggtitle("Schätzung auf Basis der gl. Durchschnitts (3 Tage): Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Dichte")
# zeige das Histogramm und die Dichteverteilung
naiv_glDS_3T_relAbw_histDie Verteilung der relativen Abweichung erscheint ebenfalls sehr breit. Unser naiver Schätzer auf Basis des gleitenden Durchschnitts der letzten 3 Tage liefert also keine gute Umsatzprognose. Augenscheinlich gibt es einige Prognosewerte, die deutlich zu hoch sind. Diese Ausreißer wollen wir nun näher untersuchen, um zu verstehen, an welchen Stellen unser Modell noch Probleme hat. Für die Untersuchung der Prognosegüte hatten wir den Datensatz prog_naiv_glDS_3T erstellt, mit dem wir jetzt weiter arbeiten.
# Untersuche die Fälle, in denen die Prognose mehr als 100% höher war als der Umsatz. Die Ausreißer verteilen sich folgendermaßen auf die Warengruuppen:
prog_naiv_glDS_3T %>%
filter(Abweichung_rel > 1) %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n())## # A tibble: 5 x 2
## Warengruppe Anzahl
## <dbl> <int>
## 1 1 132
## 2 2 1
## 3 3 19
## 4 4 60
## 5 5 14
# Offenbar haben wir ein Problem für die Warengruppen 1 (Brot) und 4 (Konditorei), die wir näher betrachen wollen. Untersuche, ob Feiertage die Ursache sind:
prog_naiv_glDS_3T %>%
filter(Abweichung_rel > 1, Warengruppe == 1 | Warengruppe == 4) %>%
group_by(Warengruppe, Feiertag) %>%
summarise(Anzahl=n())## # A tibble: 4 x 3
## # Groups: Warengruppe [2]
## Warengruppe Feiertag Anzahl
## <dbl> <dbl> <int>
## 1 1 0 113
## 2 1 1 19
## 3 4 0 59
## 4 4 1 1
# Das liefert uns keine nennenswerten Erkenntnisse, Feiertage scheinen nicht die Hauptursache für die starken Abweichungen zu sein. Untersuche, ob einzelne Wochentage besonders betroffen sind, jetzt wieder über alle Warengruppen:
prog_naiv_glDS_3T %>%
filter(Abweichung_rel > 1) %>%
group_by(Wochentag_c) %>%
summarise(Anzahl=n())## # A tibble: 7 x 2
## Wochentag_c Anzahl
## <chr> <int>
## 1 Dienstag 26
## 2 Donnerstag 8
## 3 Freitag 5
## 4 Mittwoch 23
## 5 Montag 38
## 6 Samstag 7
## 7 Sonntag 119
Wie erwartet funktioniert das Modell für die Tage Donnerstag und Freitag sehr gut, weil für diese Tage die Schätzung keine Wochenendtage einbezieht. Offenbar funktioniert das auch für den Samstag relativ gut. Für die übrigen Tage gibt es Probleme.
Wir werfen nun einen Blick auf die Top10 Abweichungen (Abweichung_rel) nach oben und nach unten: Für welche Tage liegt der Schätzer auf Basis des Vorwochenwertes besonders weit daneben? Oder gibt es Warengruppen, für die der Schätzer besonders viele große Ausreißer aufweist?
# sortiere nach der relativen Abweichung und zeige die ersten und letzten 10 Zeilen
prog_naiv_glDS_3T %>%
arrange(Abweichung_rel) %>%
head(n=10)## # A tibble: 10 x 59
## # Groups: Warengruppe [2]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2015-12-31 5 1870. 2015 0 7 2
## 2 2014-12-31 5 1879. 2014 0 6 7.4
## 3 2016-12-31 5 1705. 2016 0 7 4.9
## 4 2013-12-31 5 1626. 2013 0 4 5
## 5 2018-12-31 5 1668. 2018 0 7 7.4
## 6 2017-12-31 5 1432. 2017 0 7 8.2
## 7 2013-11-17 4 177. 2013 0 2 8.9
## 8 2014-02-23 4 430. 2014 0 1 8.6
## 9 2015-02-01 4 215. 2015 0 7 -0.2
## 10 2017-01-15 4 230. 2017 0 5 1.4
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
## # A tibble: 10 x 59
## # Groups: Warengruppe [3]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2015-04-19 1 25.5 2015 0 0 10.1
## 2 2017-01-17 4 37.2 2017 0 7 0.5
## 3 2014-02-24 4 57.8 2014 0 1 9.4
## 4 2014-04-20 1 57.8 2014 0 0 13.9
## 5 2016-01-03 5 190. 2016 0 7 -5.5
## 6 2015-11-22 1 24.8 2015 0 7 2.2
## 7 2018-04-01 1 68.3 2018 0 6 2.5
## 8 2018-04-02 1 43.2 2018 0 5 6.1
## 9 2015-10-18 1 23.1 2015 0 8 11.1
## 10 2017-04-17 1 23.2 2017 0 6 6.2
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
Für Silvester liefert unser naiver Schätzer auf Basis des gleitenden Durchschnitts offenbar systematisch zu niedrige Prognosen, besonders für Warengruppe 5 (Kuchen), was vermutlich am Verkauf der Berliner liegt. Das war zu erwarten, weil Silvester immer sehr umsatzstarke Tage sind. Für die Tage mit deutlich zu hoher Prognose ist auf den ersten Blick keine Systematik zu erkennen.
Erweiterter gl. Durchschnitt der letzten 3 Wochen- bzw. Wochenendtage
Als Erweiterung wollen wir den Umsatz für Wochentage auf Basis des Durchschnitts der letzten drei Wochentage schätzen und den Umsatz für Wochenendtage auf Basis der letzten drei Wochenendtage (Umsatz_glDS_3T_erw).
Für die Schätzung und die anschließende Ermittlung der Gütemaße verwenden wir einen eigenen Datensatz prog_naiv_glDS_3T_erw. Wir starten wieder am 01.08.2013, um die Vergleichbarkeit der naiven Modelle zu wahren.
prog_naiv_glDS_3T_erw <- df_naiv %>%
filter(Umsatz_NA == FALSE) %>% # fehlende Umsätze in den Rohdaten raus nehmen
filter(Datum >= "2013-08-01") # starte ab 01.08.2013
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
prog_naiv_glDS_3T_erw <- prog_naiv_glDS_3T_erw %>%
mutate(Prognose_zuhoch = (Umsatz_glDS_3T_erw >= Umsatz)) %>%
mutate(Abweichung = Umsatz_glDS_3T_erw - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_glDS_3T_erw - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_glDS_3T_erw - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Prognosegüte: Anteil "zu hoch prognostiziert". Ergänze dafür zunächst die Anzahl der Beobachtungen je Warengruppe (Anzahl), um danach den absoluten Anteil (Anteil_abs) und relativen Anteil (Anteil_rel) zu ermitteln.
prog_naiv_glDS_3T_erw <- prog_naiv_glDS_3T_erw %>%
group_by(Warengruppe) %>%
mutate(Anzahl = n())
prog_naiv_glDS_3T_erw %>%
group_by(Warengruppe, Prognose_zuhoch) %>%
summarise(Anteil_abs = n(), Anteil_rel = round(n() / mean(Anzahl) * 100))## # A tibble: 10 x 4
## # Groups: Warengruppe [5]
## Warengruppe Prognose_zuhoch Anteil_abs Anteil_rel
## <dbl> <lgl> <int> <dbl>
## 1 1 FALSE 1061 49
## 2 1 TRUE 1084 51
## 3 2 FALSE 1066 50
## 4 2 TRUE 1079 50
## 5 3 FALSE 1058 49
## 6 3 TRUE 1087 51
## 7 4 FALSE 996 47
## 8 4 TRUE 1102 53
## 9 5 FALSE 1052 49
## 10 5 TRUE 1093 51
# Prognosegüte: mittlere Abweichung, Standardabweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung, das 5% und das 95% Quantil für die Abweichung
prog_naiv_glDS_3T_erw %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n(), mittlUmsatz=mean(Umsatz), mittlAbw=mean(Abweichung), StdAbw=sd(Abweichung), mittlAbw_abs=mean(Abweichung_abs), mittlAbw_rel=round(mean(Abweichung_abs)/mean(Umsatz)*100), mittlAbw_quad=sum(Abweichung_quad)/n(), Abweichung_Q5 = quantile(Abweichung, probs = c(0.05)), Abweichung_Q95 = quantile(Abweichung, probs = c(0.95)))## # A tibble: 5 x 10
## Warengruppe Anzahl mittlUmsatz mittlAbw StdAbw mittlAbw_abs mittlAbw_rel
## <dbl> <int> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 2145 125. -0.720 43.5 32.2 26
## 2 2 2145 399. -1.34 69.2 48.2 12
## 3 3 2145 166. -0.510 35.5 25.5 15
## 4 4 2098 87.2 -0.0883 31.7 22.4 26
## 5 5 2145 277. -1.53 97.4 43.5 16
## # ... with 3 more variables: mittlAbw_quad <dbl>, Abweichung_Q5 <dbl>,
## # Abweichung_Q95 <dbl>
# visualisiere die relative Abweichung im Histogramm: Erhalte eine Verteilung der Abweichung
naiv_glDS_3T_erw_relAbw_hist <- ggplot(data = prog_naiv_glDS_3T_erw, aes(x = Abweichung_rel*100)) +
geom_histogram(binwidth = 5, fill="yellow", color="black", size=0.5) +
ggtitle("Schätzung auf Basis des erw. gl. Durchschnitts (3 Wochen-/Wochenendtage): Rel. Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Anzahl Beobachtungen")
# ermittle die Dichteverteilung für die Abweichung
naiv_glDS_3T_erw_relAbw_dens <- ggplot(data = prog_naiv_glDS_3T_erw, aes(x = Abweichung_rel*100)) +
geom_density(fill="yellow", color="yellow", size=0.5, alpha = 0.3) +
ggtitle("Schätzung auf Basis der erw. gl. Durchschnitts (3 Wochen-/Wochenendtage): Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Dichte")
# zeige das Histogramm und die Dichteverteilung
naiv_glDS_3T_erw_relAbw_histDie Verteilung der relativen Abweichung erscheint deutlich schmaler. Unser naiver Schätzer auf Basis des erweiterten gleitenden Durchschnitts der letzten 3 Wochentage (für Mo bis Fr) bzw. Wochenendtage (für Sa und So) liefert eine treffendere Umsatzprognose. Augenscheinlich gibt es aber immer noch einige Prognosewerte, die deutlich zu hoch sind. Diese Ausreißer wollen wir nun näher untersuchen, um zu verstehen, an welchen Stellen unser Modell noch Probleme hat. Für die Untersuchung der Prognosegüte hatten wir den Datensatz prog_naiv_glDS_3T_erw erstellt, mit dem wir jetzt weiter arbeiten.
# Untersuche die Fälle, in denen die Prognose mehr als 100% höher war als der Umsatz. Die Ausreißer verteilen sich folgendermaßen auf die Warengruuppen:
prog_naiv_glDS_3T_erw %>%
filter(Abweichung_rel > 1) %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n())## # A tibble: 4 x 2
## Warengruppe Anzahl
## <dbl> <int>
## 1 1 107
## 2 3 4
## 3 4 42
## 4 5 14
# Offenbar haben wir ein Problem für die Warengruppen 1 (Brot) und 4 (Konditorei), die wir näher betrachen wollen. Warengruppe 2 (Brötchen) taucht gar nicht auf. Untersuche, ob Feiertage die Ursache sind:
prog_naiv_glDS_3T_erw %>%
filter(Abweichung_rel > 1, Warengruppe == 1 | Warengruppe == 4) %>%
group_by(Warengruppe, Feiertag) %>%
summarise(Anzahl=n())## # A tibble: 4 x 3
## # Groups: Warengruppe [2]
## Warengruppe Feiertag Anzahl
## <dbl> <dbl> <int>
## 1 1 0 90
## 2 1 1 17
## 3 4 0 41
## 4 4 1 1
# Für die Warengruppe 1 (Brot) spielen Feiertage bei den größeren Ausreißern eine Rolle. Das alleine liefert uns aber keine nennenswerten Erkenntnisse. Untersuche, ob einzelne Wochentage besonders betroffen sind, jetzt wieder über alle Warengruppen:
prog_naiv_glDS_3T_erw %>%
filter(Abweichung_rel > 1) %>%
group_by(Wochentag_c) %>%
summarise(Anzahl=n())## # A tibble: 7 x 2
## Wochentag_c Anzahl
## <chr> <int>
## 1 Dienstag 8
## 2 Donnerstag 8
## 3 Freitag 5
## 4 Mittwoch 7
## 5 Montag 11
## 6 Samstag 37
## 7 Sonntag 91
Das Modell funktioniert - wie erwartet - deutlich besser für alle Wochentage Mo bis Fr. Allerdings gibt es offenbar noch Schwachstellen für das Wochenende: Besonders die Schätzung für Sonntage liegt auffällig oft deutlich zu hoch.
Wir werfen nun einen Blick auf die Top10 Abweichungen (Abweichung_rel) nach oben und nach unten: Für welche Tage liegt der Schätzer auf Basis des Vorwochenwertes besonders weit daneben? Oder gibt es Warengruppen, für die der Schätzer besonders viele große Ausreißer aufweist?
# sortiere nach der relativen Abweichung und zeige die ersten und letzten 10 Zeilen
prog_naiv_glDS_3T_erw %>%
arrange(Abweichung_rel) %>%
head(n=10)## # A tibble: 10 x 59
## # Groups: Warengruppe [3]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2015-12-31 5 1870. 2015 0 7 2
## 2 2018-12-31 5 1668. 2018 0 7 7.4
## 3 2016-12-31 5 1705. 2016 0 7 4.9
## 4 2014-12-31 5 1879. 2014 0 6 7.4
## 5 2013-12-31 5 1626. 2013 0 4 5
## 6 2017-12-31 5 1432. 2017 0 7 8.2
## 7 2016-05-16 4 221. 2016 0 5 11.2
## 8 2017-04-15 1 396. 2017 0 6 8.1
## 9 2018-03-31 1 417. 2018 0 7 2.2
## 10 2019-04-20 1 382. 2019 0 0 13.1
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
## # A tibble: 10 x 59
## # Groups: Warengruppe [2]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2017-04-23 1 54.2 2017 0 4 7.9
## 2 2015-11-22 1 24.8 2015 0 7 2.2
## 3 2017-01-08 5 206. 2017 0 8 2.2
## 4 2014-04-20 1 57.8 2014 0 0 13.9
## 5 2015-04-19 1 25.5 2015 0 0 10.1
## 6 2016-01-04 5 190. 2016 0 5 -6
## 7 2015-04-12 1 39.0 2015 0 5 12.4
## 8 2018-04-02 1 43.2 2018 0 5 6.1
## 9 2015-10-18 1 23.1 2015 0 8 11.1
## 10 2017-04-17 1 23.2 2017 0 6 6.2
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
Für Silvester liefert unser naiver Schätzer auf Basis des erweiterten gleitenden Durchschnitts der letzten 3 Wochen- bzw. Wochenendtage offenbar systematisch zu niedrige Prognosen, besonders für Warengruppe 5 (Kuchen), was vermutlich am Verkauf der Berliner liegt. Das war zu erwarten, weil Silvester immer sehr umsatzstarke Tage sind. Für die Tage mit deutlich hoher Prognose ist auf den ersten Blick keine Systematik zu erkennen.
Erweiterter gl. Durchschnitt der letzten 4 Wochen- bzw. Wochenendtage
Als Modellerweiterung betrachten wir nun die letzten 4 Wochen- bzw. Wochenendtage und erhoffen uns davon, dass die Schätzung für den Sonntag treffsicherer wird.
Für die Schätzung und die anschließende Ermittlung der Gütemaße verwenden wir einen eigenen Datensatz prog_naiv_glDS_4T_erw. Wir starten wieder am 01.08.2013, um die Vergleichbarkeit der naiven Modelle zu wahren.
prog_naiv_glDS_4T_erw <- df_naiv %>%
filter(Umsatz_NA == FALSE) %>% # fehlende Umsätze in den Rohdaten raus nehmen
filter(Datum >= "2013-08-01") # starte ab 01.08.2013
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
prog_naiv_glDS_4T_erw <- prog_naiv_glDS_4T_erw %>%
mutate(Prognose_zuhoch = (Umsatz_glDS_4T_erw >= Umsatz)) %>%
mutate(Abweichung = Umsatz_glDS_4T_erw - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_glDS_4T_erw - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_glDS_4T_erw - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Prognosegüte: Anteil "zu hoch prognostiziert". Ergänze dafür zunächst die Anzahl der Beobachtungen je Warengruppe (Anzahl), um danach den absoluten Anteil (Anteil_abs) und relativen Anteil (Anteil_rel) zu ermitteln.
prog_naiv_glDS_4T_erw <- prog_naiv_glDS_4T_erw %>%
group_by(Warengruppe) %>%
mutate(Anzahl = n())
prog_naiv_glDS_4T_erw %>%
group_by(Warengruppe, Prognose_zuhoch) %>%
summarise(Anteil_abs = n(), Anteil_rel = round(n() / mean(Anzahl) * 100))## # A tibble: 10 x 4
## # Groups: Warengruppe [5]
## Warengruppe Prognose_zuhoch Anteil_abs Anteil_rel
## <dbl> <lgl> <int> <dbl>
## 1 1 FALSE 1067 50
## 2 1 TRUE 1078 50
## 3 2 FALSE 1038 48
## 4 2 TRUE 1107 52
## 5 3 FALSE 1025 48
## 6 3 TRUE 1120 52
## 7 4 FALSE 980 47
## 8 4 TRUE 1118 53
## 9 5 FALSE 1036 48
## 10 5 TRUE 1109 52
# Prognosegüte: mittlere Abweichung, Standardabweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung, das 5% und das 95% Quantil für die Abweichung
prog_naiv_glDS_4T_erw %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n(), mittlUmsatz=mean(Umsatz), mittlAbw=mean(Abweichung), StdAbw=sd(Abweichung), mittlAbw_abs=mean(Abweichung_abs), mittlAbw_rel=round(mean(Abweichung_abs)/mean(Umsatz)*100), mittlAbw_quad=sum(Abweichung_quad)/n(), Abweichung_Q5 = quantile(Abweichung, probs = c(0.05)), Abweichung_Q95 = quantile(Abweichung, probs = c(0.95)))## # A tibble: 5 x 10
## Warengruppe Anzahl mittlUmsatz mittlAbw StdAbw mittlAbw_abs mittlAbw_rel
## <dbl> <int> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 2145 125. -0.831 38.0 28.4 23
## 2 2 2145 399. -1.58 64.5 46.0 12
## 3 3 2145 166. -0.451 34.1 24.5 15
## 4 4 2098 87.2 0.0940 28.3 20.5 23
## 5 5 2145 277. -2.31 93.0 42.2 15
## # ... with 3 more variables: mittlAbw_quad <dbl>, Abweichung_Q5 <dbl>,
## # Abweichung_Q95 <dbl>
# visualisiere die relative Abweichung im Histogramm: Erhalte eine Verteilung der Abweichung
naiv_glDS_4T_erw_relAbw_hist <- ggplot(data = prog_naiv_glDS_4T_erw, aes(x = Abweichung_rel*100)) +
geom_histogram(binwidth = 5, fill="orange", color="black", size=0.5) +
ggtitle("Schätzung auf Basis des erw. gl. Durchschnitts (4 Wochen-/Wochenendtage): Rel. Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Anzahl Beobachtungen")
# ermittle die Dichteverteilung für die Abweichung
naiv_glDS_4T_erw_relAbw_dens <- ggplot(data = prog_naiv_glDS_4T_erw, aes(x = Abweichung_rel*100)) +
geom_density(fill="orange", color="orange", size=0.5, alpha = 0.3) +
ggtitle("Schätzung auf Basis der erw. gl. Durchschnitts (4 Wochen-/Wochenendtage): Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Dichte")
# zeige das Histogramm und die Dichteverteilung
naiv_glDS_4T_erw_relAbw_histDie Verteilung der relativen Abweichung erscheint ebenfalls schmal. Unser naiver Schätzer auf Basis des erweiterten gleitenden Durchschnitts der letzten 4 Wochentage (für Mo bis Fr) bzw. Wochenendtage (für Sa und So) liefert eine treffendere Umsatzprognose. Augenscheinlich gibt es aber immer noch einige Prognosewerte, die deutlich zu hoch sind. Diese Ausreißer wollen wir nun näher untersuchen, um zu verstehen, an welchen Stellen unser Modell noch Probleme hat. Für die Untersuchung der Prognosegüte hatten wir den Datensatz prog_naiv_glDS_4T_erw erstellt, mit dem wir jetzt weiter arbeiten.
# Untersuche die Fälle, in denen die Prognose mehr als 100% höher war als der Umsatz. Die Ausreißer verteilen sich folgendermaßen auf die Warengruuppen:
prog_naiv_glDS_4T_erw %>%
filter(Abweichung_rel > 1) %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n())## # A tibble: 4 x 2
## Warengruppe Anzahl
## <dbl> <int>
## 1 1 75
## 2 3 4
## 3 4 32
## 4 5 12
# Offenbar haben wir ein Problem für die Warengruppen 1 (Brot) und 4 (Konditorei), die wir näher betrachen wollen. Warengruppe 2 (Brötchen) taucht gar nicht auf. Untersuche, ob Feiertage die Ursache sind:
prog_naiv_glDS_4T_erw %>%
filter(Abweichung_rel > 1, Warengruppe == 1 | Warengruppe == 4) %>%
group_by(Warengruppe, Feiertag) %>%
summarise(Anzahl=n())## # A tibble: 3 x 3
## # Groups: Warengruppe [2]
## Warengruppe Feiertag Anzahl
## <dbl> <dbl> <int>
## 1 1 0 58
## 2 1 1 17
## 3 4 0 32
# Für die Warengruppe 1 (Brot) spielen Feiertage bei den größeren Ausreißern eine Rolle. Das alleine liefert uns aber keine nennenswerten Erkenntnisse. Untersuche, ob einzelne Wochentage besonders betroffen sind, jetzt wieder über alle Warengruppen:
prog_naiv_glDS_4T_erw %>%
filter(Abweichung_rel > 1) %>%
group_by(Wochentag_c) %>%
summarise(Anzahl=n())## # A tibble: 7 x 2
## Wochentag_c Anzahl
## <chr> <int>
## 1 Dienstag 9
## 2 Donnerstag 6
## 3 Freitag 6
## 4 Mittwoch 7
## 5 Montag 19
## 6 Samstag 17
## 7 Sonntag 59
Das Modell funktioniert liefert etwas bessere Schätzungen für den Sonntag, der aber immer noch ein Problem darstellt.
Wir werfen nun einen Blick auf die Top10 Abweichungen (Abweichung_rel) nach oben und nach unten: Für welche Tage liegt der Schätzer auf Basis des Vorwochenwertes besonders weit daneben? Oder gibt es Warengruppen, für die der Schätzer besonders viele große Ausreißer aufweist?
# sortiere nach der relativen Abweichung und zeige die ersten und letzten 10 Zeilen
prog_naiv_glDS_4T_erw %>%
arrange(Abweichung_rel) %>%
head(n=10)## # A tibble: 10 x 59
## # Groups: Warengruppe [3]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2015-12-31 5 1870. 2015 0 7 2
## 2 2016-12-31 5 1705. 2016 0 7 4.9
## 3 2018-12-31 5 1668. 2018 0 7 7.4
## 4 2014-12-31 5 1879. 2014 0 6 7.4
## 5 2017-12-31 5 1432. 2017 0 7 8.2
## 6 2013-12-31 5 1626. 2013 0 4 5
## 7 2017-05-25 4 179. 2017 0 2 18.9
## 8 2016-12-29 1 282. 2016 0 3 3.8
## 9 2016-05-16 4 221. 2016 0 5 11.2
## 10 2018-03-31 1 417. 2018 0 7 2.2
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
## # A tibble: 10 x 59
## # Groups: Warengruppe [3]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2014-04-20 1 57.8 2014 0 0 13.9
## 2 2014-09-07 1 49.0 2014 0 5 20
## 3 2014-02-24 4 57.8 2014 0 1 9.4
## 4 2016-01-04 5 190. 2016 0 5 -6
## 5 2015-11-22 1 24.8 2015 0 7 2.2
## 6 2015-04-12 1 39.0 2015 0 5 12.4
## 7 2015-04-19 1 25.5 2015 0 0 10.1
## 8 2018-04-02 1 43.2 2018 0 5 6.1
## 9 2015-10-18 1 23.1 2015 0 8 11.1
## 10 2017-04-17 1 23.2 2017 0 6 6.2
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
Für Silvester liefert unser naiver Schätzer auf Basis des erweiterten gleitenden Durchschnitts der letzten 4 Wochen- bzw. Wochenendtage offenbar systematisch zu niedrige Prognosen, besonders für Warengruppe 5 (Kuchen), was vermutlich am Verkauf der Berliner liegt. Das war zu erwarten, weil Silvester immer sehr umsatzstarke Tage sind. Für die Tage mit deutlich hoher Prognose ist auf den ersten Blick keine Systematik zu erkennen.
5.5 Prognose der Umsätze anhand des gewichteten Vorwochendurchschnitts
Nun betrachten wir einen gewichteten Mittelwert der Vorwochen (Umsatz_gewMW_4W) als Schätzer. Hierbei gewichten wir den Wert der Vorwoche mit 50%, den Wert zwei Wochen zurück mit 25% und den Wert drei Wochen zurück mit 15% und den Wert vier Wochen zurück mit 10%.
Für die Schätzung und die anschließende Ermittlung der Gütemaße verwenden wir einen eigenen Datensatz prog_naiv_gewMW_4W. Wir starten wieder am 01.08.2013, um die Vergleichbarkeit der naiven Modelle zu wahren.
prog_naiv_gewMW_4W <- df_naiv %>%
filter(Umsatz_NA == FALSE) %>% # fehlende Umsätze in den Rohdaten raus nehmen
filter(Datum >= "2013-08-01") # starte ab 01.08.2013
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
prog_naiv_gewMW_4W <- prog_naiv_gewMW_4W %>%
mutate(Prognose_zuhoch = (Umsatz_gewMW_4W >= Umsatz)) %>%
mutate(Abweichung = Umsatz_gewMW_4W - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_gewMW_4W - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_gewMW_4W - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Prognosegüte: Anteil "zu hoch prognostiziert". Ergänze dafür zunächst die Anzahl der Beobachtungen je Warengruppe (Anzahl), um danach den absoluten Anteil (Anteil_abs) und relativen Anteil (Anteil_rel) zu ermitteln.
prog_naiv_gewMW_4W <- prog_naiv_gewMW_4W %>%
group_by(Warengruppe) %>%
mutate(Anzahl = n())
prog_naiv_gewMW_4W %>%
group_by(Warengruppe, Prognose_zuhoch) %>%
summarise(Anteil_abs = n(), Anteil_rel = round(n() / mean(Anzahl) * 100))## # A tibble: 10 x 4
## # Groups: Warengruppe [5]
## Warengruppe Prognose_zuhoch Anteil_abs Anteil_rel
## <dbl> <lgl> <int> <dbl>
## 1 1 FALSE 1033 48
## 2 1 TRUE 1112 52
## 3 2 FALSE 985 46
## 4 2 TRUE 1160 54
## 5 3 FALSE 1007 47
## 6 3 TRUE 1138 53
## 7 4 FALSE 977 47
## 8 4 TRUE 1121 53
## 9 5 FALSE 1000 47
## 10 5 TRUE 1145 53
# Prognosegüte: mittlere Abweichung, Standardabweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung, das 5% und das 95% Quantil für die Abweichung
prog_naiv_gewMW_4W %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n(), mittlUmsatz=mean(Umsatz), mittlAbw=mean(Abweichung), StdAbw=sd(Abweichung), mittlAbw_abs=mean(Abweichung_abs), mittlAbw_rel=round(mean(Abweichung_abs)/mean(Umsatz)*100), mittlAbw_quad=sum(Abweichung_quad)/n(), Abweichung_Q5 = quantile(Abweichung, probs = c(0.05)), Abweichung_Q95 = quantile(Abweichung, probs = c(0.95)))## # A tibble: 5 x 10
## Warengruppe Anzahl mittlUmsatz mittlAbw StdAbw mittlAbw_abs mittlAbw_rel
## <dbl> <int> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 2145 125. -0.189 35.4 25.4 20
## 2 2 2145 399. 0.435 79.9 58.4 15
## 3 3 2145 166. -0.120 44.3 32.8 20
## 4 4 2098 87.2 0.0487 28.5 20.3 23
## 5 5 2145 277. 0.395 104. 47.7 17
## # ... with 3 more variables: mittlAbw_quad <dbl>, Abweichung_Q5 <dbl>,
## # Abweichung_Q95 <dbl>
# visualisiere die relative Abweichung im Histogramm: Erhalte eine Verteilung der Abweichung
naiv_gewMW_4W_relAbw_hist <- ggplot(data = prog_naiv_gewMW_4W, aes(x = Abweichung_rel*100)) +
geom_histogram(binwidth = 5, fill="purple", color="black", size=0.5) +
ggtitle("Schätzung auf Basis des gewichteten Vorwochendurchschnitts: Rel. Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Anzahl Beobachtungen")
# ermittle die Dichteverteilung für die Abweichung
naiv_gewMW_4W_relAbw_dens <- ggplot(data = prog_naiv_gewMW_4W, aes(x = Abweichung_rel*100)) +
geom_density(fill="purple", color="purple", size=0.5, alpha = 0.3) +
ggtitle("Schätzung auf Basis des gewichteten Vorwochendurchschnitts: Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Dichte")
# zeige das Histogramm und die Dichteverteilung
naiv_gewMW_4W_relAbw_histDie Verteilung der relativen Abweichung erscheint zwar breit. Aber es scheint weniger Ausreißer nach oben zu geben, als in den anderen naiven Modellen. Unser naiver Schätzer auf Basis des gewichteten Vorwochendurchschnitts liefert insgesamt keine gute Umsatzprognose. Augenscheinlich gibt es einige Prognosewerte, die deutlich zu hoch sind. Diese Ausreißer wollen wir nun näher untersuchen, um zu verstehen, an welchen Stellen unser Modell noch Probleme hat. Für die Untersuchung der Prognosegüte hatten wir den Datensatz prog_naiv_gewMW_4W erstellt, mit dem wir jetzt weiter arbeiten.
# Untersuche die Fälle, in denen die Prognose mehr als 100% höher war als der Umsatz. Die Ausreißer verteilen sich folgendermaßen auf die Warengruuppen:
prog_naiv_gewMW_4W %>%
filter(Abweichung_rel > 1) %>%
group_by(Warengruppe) %>%
summarise(Anzahl=n())## # A tibble: 5 x 2
## Warengruppe Anzahl
## <dbl> <int>
## 1 1 33
## 2 2 2
## 3 3 4
## 4 4 38
## 5 5 14
# Offenbar haben wir ein Problem für die Warengruppen 1 (Brot) und 4 (Konditorei), die wir näher betrachen wollen. Untersuche, ob Feiertage die Ursache sind:
prog_naiv_gewMW_4W %>%
filter(Abweichung_rel > 1, Warengruppe == 1 | Warengruppe == 4) %>%
group_by(Warengruppe, Feiertag) %>%
summarise(Anzahl=n())## # A tibble: 3 x 3
## # Groups: Warengruppe [2]
## Warengruppe Feiertag Anzahl
## <dbl> <dbl> <int>
## 1 1 0 23
## 2 1 1 10
## 3 4 0 38
# Für die Warengruppe 1 (Brot) spielen Feiertage bei den größeren Ausreißern eine Rolle. Das alleine liefert uns aber keine nennenswerten Erkenntnisse. Untersuche, ob einzelne Wochentage besonders betroffen sind, jetzt wieder über alle Warengruppen:
prog_naiv_gewMW_4W %>%
filter(Abweichung_rel > 1) %>%
group_by(Wochentag_c) %>%
summarise(Anzahl=n())## # A tibble: 7 x 2
## Wochentag_c Anzahl
## <chr> <int>
## 1 Dienstag 8
## 2 Donnerstag 15
## 3 Freitag 6
## 4 Mittwoch 15
## 5 Montag 14
## 6 Samstag 17
## 7 Sonntag 16
Die Schätzung auf Basis des gewichteten Durchschnitts der letzten 4 Wochen liefert offenbar für alle Wochentage wenig Ausreißer nach oben.
Wir werfen nun einen Blick auf die Top10 Abweichungen (Abweichung_rel) nach oben und nach unten: Für welche Tage liegt der Schätzer auf Basis des Vorwochenwertes besonders weit daneben? Oder gibt es Warengruppen, für die der Schätzer besonders viele große Ausreißer aufweist?
# sortiere nach der relativen Abweichung und zeige die ersten und letzten 10 Zeilen
prog_naiv_gewMW_4W %>%
arrange(Abweichung_rel) %>%
head(n=10)## # A tibble: 10 x 59
## # Groups: Warengruppe [2]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2015-12-31 5 1870. 2015 0 7 2
## 2 2013-12-31 5 1626. 2013 0 4 5
## 3 2016-12-31 5 1705. 2016 0 7 4.9
## 4 2014-12-31 5 1879. 2014 0 6 7.4
## 5 2018-12-31 5 1668. 2018 0 7 7.4
## 6 2017-12-31 5 1432. 2017 0 7 8.2
## 7 2016-02-04 4 213. 2016 0 5 4.2
## 8 2016-05-16 4 221. 2016 0 5 11.2
## 9 2015-02-06 4 220. 2015 0 2 -0.5
## 10 2016-02-06 4 192. 2016 0 7 9.4
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
## # A tibble: 10 x 59
## # Groups: Warengruppe [3]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2015-10-18 1 23.1 2015 0 8 11.1
## 2 2014-03-02 4 108. 2014 0 6 6.6
## 3 2018-04-02 1 43.2 2018 0 5 6.1
## 4 2017-04-22 1 81.4 2017 0 5 7.5
## 5 2017-01-07 5 266. 2017 0 8 -0.5
## 6 2019-01-07 5 250. 2019 0 8 5.9
## 7 2015-01-07 5 263. 2015 0 6 5.8
## 8 2014-01-07 5 211. 2014 0 7 10.4
## 9 2016-01-07 5 212. 2016 0 7 -4
## 10 2017-04-17 1 23.2 2017 0 6 6.2
## # ... with 52 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>
Für Silvester liefert unser naiver Schätzer auf Basis des erweiterten gleitenden Durchschnitts der letzten 4 Wochen- bzw. Wochenendtage offenbar systematisch zu niedrige Prognosen, besonders für Warengruppe 5 (Kuchen), was vermutlich am Verkauf der Berliner liegt. Das war zu erwarten, weil Silvester immer sehr umsatzstarke Tage sind. Ebenso liefert das Modell für den 7. Januar konsequent zu hohe Schätzwerte, weil diese - zumindest zu einem großen Teil (50%) - auf Basis der sehr hohen Silvester-Umsätze prognostiziert werden.
5.6 Vergleich der naiven Modelle
Wir wollen jetzt die Ergebnisse der verschiedenen naiven Modelle vergleichen. Und zwar beschränken wir uns auf das Jahr 2018, weil wir die späteren Modelle (lineare Regression, Support Vector Machines, Multilayer-Perceptron,…) ebenfalls für das Jahr 2018 testen werden und einen Vergleich zu den naiven Modellen herstellen wollen.
Wir haben in diesem Kapitel die folgenden Analysedatensätze verwendet und gefüllt:
- prog_naiv_lag_1W
- prog_naiv_glDS_3T
- prog_naiv_glDS_3T_erw
- prog_naiv_glDS_4T_erw
- prog_naiv_gewMW_4W
Vergleich der relativen Abweichung
Nun bringen wir die relativen Abweichungen in einem Datensatz zusammen, je Datum, Warengruppe und Modell, um damit Facetten-Plots der Dichteverteilung und Boxplots der Verteilungen zu erstellen.
Als Grundgerüst (Datum, Warengruppe, Jahr, Wochentag) für die gemeinsame Tabelle dient uns der ursprüngliche Datensatz df_naiv. Wir starten ab dem 01.08.2013, weil wir ab diesem Datum Schätzer für alle Modelle haben. Und wir streichen die Datensätze, für die die Umsätze in den Rohdaten fehlen.
prog_naiv_vgl_relAbw <- df_naiv %>%
filter(Umsatz_NA == FALSE) %>% # fehlende Umsätze in den Rohdaten raus nehmen
filter(Datum >= "2013-08-01") %>% # starte ab 01.08.2013
dplyr::select(Datum, Warengruppe, Jahr, Wochentag, Wochentag_c, SommerferienSH, Feiertag) # behalte nur diese SpaltenFüge als nächstes die relativen Abweichungen an die Tabelle an:
prog_naiv_vgl_relAbw <- prog_naiv_vgl_relAbw %>%
mutate(lag_1W = prog_naiv_lag_1W$Abweichung_rel) %>%
mutate(glDS_3T = prog_naiv_glDS_3T$Abweichung_rel) %>%
mutate(glDS_3T_erw = prog_naiv_glDS_3T_erw$Abweichung_rel) %>%
mutate(glDS_4T_erw = prog_naiv_glDS_4T_erw$Abweichung_rel) %>%
mutate(gewMW_4W = prog_naiv_gewMW_4W$Abweichung_rel)Wir müssen die Tabelle noch pivotisieren (pivot_longer), als Vorbereitung für den anschließenden Plot:
prog_naiv_vgl_relAbw <- prog_naiv_vgl_relAbw %>%
pivot_longer(cols=-c("Datum", "Warengruppe", "Jahr", "Wochentag", "Wochentag_c", "SommerferienSH", "Feiertag"), names_to="Modell", values_to="Abweichung_rel")Stelle nun die Verteilung der relativen Abweichung für die verschiedenen naiven Modelle in einem Plot dar, examplarisch für die Warengruppe 1:
prog_naiv_vgl_relAbw %>%
filter(Jahr == 2018 & Warengruppe==1) %>%
ggplot(mapping=aes(x=Abweichung_rel*100)) +
geom_density(aes(color=Modell), alpha=0.3) +
scale_color_manual(breaks = c("lag_1W", "glDS_3T", "glDS_3T_erw", "glDS_4T_erw", "gewMW_4W"), values=c("steelblue", "red", "yellow", "orange", "purple")) +
ggtitle("2018 / WG1 - Vergleich der naiven Modelle: Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Dichte") +
xlim(-100, 200)## Warning: Removed 13 rows containing non-finite values (stat_density).
Man könnte hier noch die Verteilungen für die übrigen Warengruppen darstellen, der Erkenntnisgewinn ist jedoch vermutlich gering, daher verzichten wir darauf.
Stattdessen stellen wir die Verteilungen im Vergleich exemplarisch für Montag dar:
prog_naiv_vgl_relAbw %>%
filter(Jahr == 2018 & Wochentag_c=="Montag") %>%
ggplot(mapping=aes(x=Abweichung_rel*100)) +
geom_density(aes(color=Modell), alpha=0.3) +
scale_color_manual(breaks = c("lag_1W", "glDS_3T", "glDS_3T_erw", "glDS_4T_erw", "gewMW_4W"), values=c("steelblue", "red", "yellow", "orange", "purple")) +
ggtitle("2018 / Montag - Vergleich der naiven Modelle: Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Dichte") +
xlim(-100, 200)## Warning: Removed 5 rows containing non-finite values (stat_density).
Um die Dichteverteilungen besser vergleichen zu können, wählen wir Boxplots und können dann auch die Verteilungen für alle Warengruppen und Wochentage in einem Facetten-Plot zeigen.
# Jahr 2018, alle Wochentage und Warengruppen
prog_naiv_vgl_relAbw %>%
filter(Jahr == 2018) %>%
ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
geom_boxplot() + coord_flip() +
ggtitle("2018 - Vergleich der naiven Modelle: Relative Abweichung") +
xlab("Modell") +
ylab("rel. Abweichung (%)") +
ylim(-100, 200)## Warning: Removed 14 rows containing non-finite values (stat_boxplot).
# Jahr 2018, nur Montage, alle Warengruppen
# prog_naiv_vgl_relAbw %>%
# filter(Jahr == 2018 & Wochentag_c=="Montag") %>%
# ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
# geom_boxplot() + coord_flip() +
# ggtitle("2018 / Montag - Vergleich der naiven Modelle: Relative Abweichung") +
# xlab("Modell") +
# ylab("rel. Abweichung (%)") +
# ylim(-100, 200)
# Jahr 2018, nur Sonntage, alle Warengruppen
#prog_naiv_vgl_relAbw %>%
# filter(Jahr == 2018 & Wochentag_c=="Sonntag") %>%
# ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
# geom_boxplot() + coord_flip() +
# ggtitle("2018 / Sonntag - Vergleich der naiven Modelle: Relative Abweichung") +
# xlab("Modell") +
# ylab("rel. Abweichung (%)") +
# ylim(-100, 200)
# Jahr 2018, nach Wochentag, alle Warengruppen
# Wochentag_c sortiert nach Wochentag
prog_naiv_vgl_relAbw %>%
filter(Jahr == 2018) %>%
mutate(Wochentag_ord = reorder(Wochentag_c,Wochentag)) %>%
ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
geom_boxplot() + coord_flip() +
ggtitle("2018 - Vergleich der naiven Modelle: Rel. Abweichung nach Wochentag") +
xlab("Modell") +
ylab("rel. Abweichung (%)") +
ylim(-100, 200) +
facet_wrap(vars(Wochentag_ord))## Warning: Removed 14 rows containing non-finite values (stat_boxplot).
# Jahr 2018, nach Warengruppen, alle Wochentage
prog_naiv_vgl_relAbw %>%
filter(Jahr == 2018) %>%
ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
geom_boxplot() + coord_flip() +
ggtitle("2018 - Vergleich der naiven Modelle: Rel. Abweichung nach Warengruppe") +
xlab("Modell") +
ylab("rel. Abweichung (%)") +
ylim(-100, 200) +
facet_wrap(vars(Warengruppe))## Warning: Removed 14 rows containing non-finite values (stat_boxplot).
# Jahr 2018, nach Warengruppen, alle Wochentage, OHNE Sommerferien und OHNE Feiertage
prog_naiv_vgl_relAbw %>%
filter(Jahr == 2018 & SommerferienSH == 0 & Feiertag == 0) %>%
ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
geom_boxplot() + coord_flip() +
ggtitle("2018 OHNE SoFerien u. Feiertage - Vgl. der naiven Modelle: Rel. Abw. nach Warengruppe") +
xlab("Modell") +
ylab("rel. Abweichung (%)") +
ylim(-100, 200) +
facet_wrap(vars(Warengruppe))## Warning: Removed 7 rows containing non-finite values (stat_boxplot).
Vergleicht man die Dichteverteilungen für das Jahr 2018 insgesamt (über alle Warengruppen und Wochentage), liefert der erweiterte gleitende Durchschnitt der letzten 4 Wochen- bzw. Wochenendtage die besten Ergebnisse.
Unterteilt man die Verteilungen nach Wochentag oder Warengruppe, ergibt sich ein differenzierteres Bild:
Nach Wochentag liefert der erweiterte gleitende Durchschnitt der letzten 3 Wochen- bzw. Wochenendtage die besten Ergebnisse unter der Woche (Mo bis Fr), versagt aber an Wochenenden (Sa und So), wie wir bereits gesehen hatten. Für Samstage liefert der erweiterte gleitende Durchschnitt der letzten 4 anstatt 3 Wochen- bzw. Wochenendtage die besten Ergebnisse. Für Sonntage liefert das einfachste Modell auf Basis des Vorwochenwertes offenbar die treffendsten Schätzer.
Nach Warengruppe liefert der gleitende Durchschnitt der letzten 3 Tage die besten Ergebnisse für Warengruppe 1 (Brot). Die übrigen Warengruppen werden durch den erweiterten gleitenden Durchschnitt der letzten 3 Wochen- bzw. Wochenendtagen am besten prognostiziert.
Guckt man sich die Verteilungen nach Warengruppe OHNE Sommerferien und OHNE Feiertage an, erhält man fast identische Ergebnisse.
Vergleich der Gütekennzahlen
Wir wollen nun die ermittelten Gütekennzahlen für die verschiedenen naiven Modelle verfeinern und zusammen bringen. Dafür erstellen wir eine Vergleichstabelle (prog_naiv_vgl_kennz), die die Kennzahlen je Modell für 2018 enthält. Im ersten Schritt betrachten wir nur die Gesamtgüte für die 5 Modelle und trennen erst später nach Warengruppen und Wochentagen.
Wir möchten nun folgende Gütekennzahlen für die Umsatzschätzung vergleichen:
- mittlere absolute Abweichung (MAE)
- mittlere relative Abweichung (MPE)
- mittlere Absolutwert der relativen Abweichung (MAPE)
- gewichtetes Mittel des Absolutwerts der relativen Abweichung (WAPE)
- mittlere quadratische Abweichung (MSE)
- Wurzel der mittleren quadratischen Abweichung (RMSE)
- Wurzel der mittleren quadratischen Abweichung relativ zum mittleren Umsatz (rRMSE)
Die mittlere absulute Abweichung (MAE = mean absolute error) gibt uns ein Gefühl, wie start der Schätzer vom tatsächlichen Umsatz abweicht.
Die mittlere relative Abweichung (MPE = mean percentage error) gibt uns Anhaltspunkte, ob und wir stark die Prognose eines Modells systematisch daneben liegt - in Prozent.
Der mittlere Absolutwert der relativen Abweichung (MAPE = mean absolute percentage error) verrät uns, wie stark die Schätzung im Mittel vom tatsächlichen Umsatz abweicht - in beide Richtungen - in Prozent.
Das gewichtete Mittel des Absolutwerts der relativen Abweichung (WAPE = weighted absolute percentage error) bezieht den Umsatz des Schätzers zusätzlich als Gewicht mit ein. Das Ergebnis ist ebenfalls ein Prozentwert.
Die mittlere quadratische Abweichung (MSE = mean squared error) bestraft größere Abweichungen stärker als die übrigen Kennzahlen.
Üblicherweise vergleicht man jedoch die Wurzel der mittleren quadratischen Abweichung (RMSE = root mean squared error). Und wir wollen diese Größe noch ins Verhältnis zum mittleren Umsatz setzen und erhalten eine neue Kennzahl (rRMSE), die uns einen Anhaltspunkt über vorliegende starke Abweichungen der Schätzwerte vom tatsächlichen Umsatz gibt.
Wir haben in diesem Kapitel bisher die folgenden Analysedatensätze verwendet und gefüllt:
- prog_naiv_lag_1W
- prog_naiv_glDS_3T
- prog_naiv_glDS_3T_erw
- prog_naiv_glDS_4T_erw
- prog_naiv_gewMW_4W
Diese enthalten schon:
- Abweichung: Differenz zwischen prognostiziertem und tatsächlichem Umsatz
- Abweichung_abs: Der Absolutwert der Abweichung
- Abweichung_rel: Die relative Abweichung
Wir benötigen noch weitere Hilfsgrößen:
- Abweichung_rel_abs: Der Absolutwert der relativen Abweichung
- Abweichung_rel_abs_mult_Umsatz: Das ganze noch multipliziert mit dem tatsächlichen Umsatz
# starte mit lag_1W: Ergänze die benötigten Hilfsgrößen
prog_naiv_lag_1W <- prog_naiv_lag_1W %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- prog_naiv_lag_1W %>%
group_by() %>%
filter(Jahr==2018) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "lag_1W")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_kennz <- temp
# weiter mit glDS_3T: Ergänze die benötigten Hilfsgrößen
prog_naiv_glDS_3T <- prog_naiv_glDS_3T %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- prog_naiv_glDS_3T %>%
group_by() %>%
filter(Jahr==2018) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "glDS_3T")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_kennz <- rbind(prog_naiv_vgl_kennz, temp)
# weiter mit glDS_3T_erw: Ergänze die benötigten Hilfsgrößen
prog_naiv_glDS_3T_erw <- prog_naiv_glDS_3T_erw %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- prog_naiv_glDS_3T_erw %>%
group_by() %>%
filter(Jahr==2018) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "glDS_3T_erw")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_kennz <- rbind(prog_naiv_vgl_kennz, temp)
# weiter mit glDS_4T_erw: Ergänze die benötigten Hilfsgrößen
prog_naiv_glDS_4T_erw <- prog_naiv_glDS_4T_erw %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- prog_naiv_glDS_4T_erw %>%
group_by() %>%
filter(Jahr==2018) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "glDS_4T_erw")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_kennz <- rbind(prog_naiv_vgl_kennz, temp)
# weiter mit gewMW_4W: Ergänze die benötigten Hilfsgrößen
prog_naiv_gewMW_4W <- prog_naiv_gewMW_4W %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- prog_naiv_gewMW_4W %>%
group_by() %>%
filter(Jahr==2018) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "gewMW_4W")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_kennz <- rbind(prog_naiv_vgl_kennz, temp)
head(prog_naiv_vgl_kennz)## # A tibble: 5 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1789 372262 208 39 4 21 19 4660 68 33
## 2 1789 372262 208 44 6 24 21 4590 68 33
## 3 1789 372262 208 33 4 19 16 3436 59 28
## 4 1789 372262 208 31 4 18 15 3017 55 26
## 5 1789 372262 208 36 4 19 17 3793 62 30
## # ... with 1 more variable: Modell <chr>
Im Vergleich der Gütekennzahlen fällt auf, dass alle Modelle den Umsatz im Schnitt zu hoch schätzen und zwar um 4 bis 6% (MPE). Der erweiterte gleitende Durchschnitt der letzten 4 Wochen- bzw. Wochenendtage (glDS_4T_erw) schneidet am besten ab - zumindest in der Gesamtsicht: WAPE und rRMSE zeigen die niedrigsten Werte. Wir wollen nun die Kennzahlen für dieses Modell je warengruppe und Wochentag betrachten.
temp <- prog_naiv_glDS_4T_erw %>%
group_by(Warengruppe) %>%
filter(Jahr==2018) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
temp## # A tibble: 5 x 11
## Warengruppe Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE
## <dbl> <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 1 358 47292 132 30 9 26 23 1723
## 2 2 358 135858 379 41 1 11 11 3235
## 3 3 358 61867 173 26 3 16 15 1242
## 4 4 357 29606 83 17 5 21 20 459
## 5 5 358 97639 273 43 2 15 16 8418
## # ... with 2 more variables: RMSE <dbl>, rRMSE <dbl>
Wenn wir uns das Modell (glDS_4T_erw) genauer angucken, sehen wir, dass die Schätzung für die Warengruppe 2 (Brötchen) am besten funktioniert. Der Mittelwert der relativen Abweichung (MPE) liegt nahe Null. Das gewichtete Mittel des Absolutwerts der relativen Abweichung (WAPE) zeigt mit 11 den niedrigsten Wert. Auch der Wert für rRMSE ist deutlich niedriger als für die übrigen Warengruppen, es liegen also weniger starke Abweichungen der Schätzwerte vom tatsächlichen Umsatz vor.
Auch für Warengruppe 5 (Kuchen) liefert das Modell offenbar gute Schätzungen. Auffällig ist jedoch, dass die mittlere quadratische Abweichung (MSE) deutlich höher ist, als für die anderen Warengruppen. Das liegt am Schätzfehler für Silvester: Wie wir bereits gesehen hatten, haben wir in der Warengruppe auffällig hohen Umsatz durch den Berlinerverkauf.
Zuletzt gucken wir uns die Gütekennzahlen für dieses Modell je Wochentag an.
temp <- prog_naiv_glDS_4T_erw %>%
group_by(Wochentag_c) %>%
filter(Jahr==2018) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
temp## # A tibble: 7 x 11
## Wochentag_c Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE
## <chr> <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 Dienstag 250 47068 188 25 5 16 13 1174
## 2 Donnerstag 260 51426 198 26 -3 15 13 1410
## 3 Freitag 255 50703 199 22 -3 13 11 925
## 4 Mittwoch 250 46145 185 22 8 16 12 815
## 5 Montag 254 50733 200 42 10 22 21 10013
## 6 Samstag 260 63057 243 39 1 18 16 3679
## 7 Sonntag 260 63130 243 42 10 26 17 3068
## # ... with 2 more variables: RMSE <dbl>, rRMSE <dbl>
Offenbar versagt dieses Modell für Montage und Sonntage: Allein die mittlere relative Abweichung (MPE) liegt für diese beiden Tage bei 10%.
Top10 Tage der größten Abweichungen
Wir untersuchen nun die Tage mit den größten Abweichungen nach oben und unten für die verschiedenen naiven Modelle. Dabei beschränken wir uns auf das Jahr 2018, weil dieser Zeitraum auch für die anderen Modelle als Testzeitraum feststeht und wir dann die Modelle besser vergleichen können. Wir erstellen eine gemeinsame Tabelle für alle Modelle (prog_naiv_vgl_top).
Wir wollen rausfinden, ob es Tage gibt, die in allen Modellen schlecht prognostiziert werden. Für die zu niedrigen Prognosen war das vor allem der Silvester in WG5 (Kuchen = Berliner). Aber was ist mit den Tagen, an denen die Prognose zu hoch war? Den 7. Januar haben wir für einige Modelle schon erklärt. Gibt es weitere auffällige Tage? Oder führen bspw. die Sommerferien systematisch zu größeren Abweichungen?
# starte mit lag_1W: Größte rel. Abweichungen, bei denen der Umsatz zu hoch geschätzt wurde
temp <- prog_naiv_lag_1W %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
head(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "lag_1W") %>%
mutate(Prognose = "zu tief")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- temp
# Größte rel. Abweichungen, bei denen der Umsatz zu niedrig geschätzt wurde
temp <- prog_naiv_lag_1W %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
tail(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "lag_1W") %>%
mutate(Prognose = "zu hoch")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)
# weiter mit glDS_3T: Größte rel. Abweichungen, bei denen der Umsatz zu hoch geschätzt wurde
temp <- prog_naiv_glDS_3T %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
head(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "glDS_3T") %>%
mutate(Prognose = "zu tief")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)
# Größte rel. Abweichungen, bei denen der Umsatz zu niedrig geschätzt wurde
temp <- prog_naiv_glDS_3T %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
tail(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "glDS_3T") %>%
mutate(Prognose = "zu hoch")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)
# weiter mit glDS_3T_erw: Größte rel. Abw., bei denen der Umsatz zu hoch geschätzt wurde
temp <- prog_naiv_glDS_3T_erw %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
head(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "glDS_3T_erw") %>%
mutate(Prognose = "zu tief")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)
# Größte rel. Abweichungen, bei denen der Umsatz zu niedrig geschätzt wurde
temp <- prog_naiv_glDS_3T_erw %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
tail(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "glDS_3T_erw") %>%
mutate(Prognose = "zu hoch")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)
# weiter mit glDS_4T_erw: Größte rel. Abw., bei denen der Umsatz zu hoch geschätzt wurde
temp <- prog_naiv_glDS_4T_erw %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
head(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "glDS_4T_erw") %>%
mutate(Prognose = "zu tief")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)
# Größte rel. Abweichungen, bei denen der Umsatz zu niedrig geschätzt wurde
temp <- prog_naiv_glDS_4T_erw %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
tail(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "glDS_4T_erw") %>%
mutate(Prognose = "zu hoch")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)
# weiter mit gewMW_4W: Größte rel. Abw., bei denen der Umsatz zu hoch geschätzt wurde
temp <- prog_naiv_gewMW_4W %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
head(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "gewMW_4W") %>%
mutate(Prognose = "zu tief")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)
# Größte rel. Abweichungen, bei denen der Umsatz zu niedrig geschätzt wurde
temp <- prog_naiv_gewMW_4W %>%
filter(Jahr==2018) %>%
arrange(Abweichung_rel) %>%
tail(n=10)
# füge das Modell und die Kategorie hinzu
temp <- temp %>%
mutate(Modell = "gewMW_4W") %>%
mutate(Prognose = "zu hoch")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_naiv_vgl_top <- rbind(prog_naiv_vgl_top, temp)Nun wollen wir im Detail analysieren, für welche Tage der Umsatz systematisch zu hoch oder zu tief geschätzt wird durch unsere verschiedenen naiven Modelle.
prog_naiv_vgl_top %>%
group_by(Datum, Prognose) %>%
summarise(Anzahl = n()) %>%
arrange(desc(Anzahl))## # A tibble: 45 x 3
## # Groups: Datum [44]
## Datum Prognose Anzahl
## <date> <chr> <int>
## 1 2018-03-29 zu tief 10
## 2 2018-12-31 zu tief 8
## 3 2018-03-31 zu tief 5
## 4 2018-04-02 zu hoch 5
## 5 2018-06-23 zu tief 4
## 6 2018-11-10 zu hoch 4
## 7 2018-01-06 zu hoch 3
## 8 2018-02-18 zu hoch 3
## 9 2018-03-18 zu tief 3
## 10 2018-04-01 zu hoch 3
## # ... with 35 more rows
Die erste Beobachtung ist, dass einige Daten mehrfach auftauchen. Auffällig ist - wie schon bekannt - Silvester: Dieser Tag ist in jedem Jahr sehr umsatzstark und wird von den naiven Modellen auf Basis der jüngeren Vergangenheit nicht gut vorhergesagt. Und dann fällt noch der 29.03.2018 auf.
Um insgesamt besser zu verstehen, was die stark zu hohen oder zu niedrigen Schätzwerte verursacht, nehmen wir weitere Einflussfaktoren für die gefundenen Daten hinzu:
prog_naiv_vgl_top %>%
group_by(Datum, Warengruppe, Prognose) %>%
summarise(Anzahl = n()) %>%
arrange(desc(Anzahl))## # A tibble: 53 x 4
## # Groups: Datum, Warengruppe [53]
## Datum Warengruppe Prognose Anzahl
## <date> <dbl> <chr> <int>
## 1 2018-03-29 1 zu tief 5
## 2 2018-03-29 3 zu tief 5
## 3 2018-04-02 1 zu hoch 5
## 4 2018-12-31 5 zu tief 5
## 5 2018-03-31 1 zu tief 4
## 6 2018-06-23 5 zu tief 4
## 7 2018-11-10 4 zu hoch 4
## 8 2018-02-18 1 zu hoch 3
## 9 2018-04-01 1 zu hoch 3
## 10 2018-05-24 4 zu hoch 3
## # ... with 43 more rows
Jetzt sehen wir u.a., dass für den 29.03.2018 die Umsätze in den Warengruppen 1 und 3 für alle 5 naiven Modellen zu tief geschätzt wird. Und Silvester wird die Warengruppe 5 (Kuchen = Berliner) ebenfalls in allen Modelle zu tief geschätzt.
Für fast alle Daten ist die Prognose entweder konsequent zu hoch oder konsequent zu tief. Das Datum 07.01.2018 ist das einzige Datum, für das je zwei Schätzungen stark zu hoch (Warengruppe 5) bzw. stark zu niedrieg (Warengruppe 4) waren. Es handelt sich um den Tag eine Woche nach Silvester, der in den Modellen auf Basis des Vorwochendurchschnitts (lag_1W) und des gewichteten Vorwochendurchschnitts (gewDS_4W) schlecht geschätzt wird, weil die Schätzgrundlage (Silvester) verzerrt ist.
Wir prüfen nun, ob allgemein Ferien oder Feiertage für die Tage mit starken Abweichungen zwischen Schätzer und tatsächlichem Umsatz eine Rolle spielen.
prog_naiv_vgl_top %>%
group_by(Prognose, SommerferienSH) %>%
summarise(Anzahl = n()) %>%
arrange(desc(Anzahl))## # A tibble: 3 x 3
## # Groups: Prognose [2]
## Prognose SommerferienSH Anzahl
## <chr> <dbl> <int>
## 1 zu hoch 0 50
## 2 zu tief 0 47
## 3 zu tief 1 3
prog_naiv_vgl_top %>%
group_by(Prognose, Feiertag) %>%
summarise(Anzahl = n()) %>%
arrange(desc(Anzahl))## # A tibble: 4 x 3
## # Groups: Prognose [2]
## Prognose Feiertag Anzahl
## <chr> <dbl> <int>
## 1 zu tief 0 42
## 2 zu hoch 0 39
## 3 zu hoch 1 11
## 4 zu tief 1 8
Die Sommerferien in Schleswig-Holstein haben offenbar nichts mit der schlechten Schätzung zu tun. Die Feiertage hingegen schon, aber das hatten wir erwartet: Besonders Silvester hat hier einen nennenswerten Einfluss.
Als letztes gucken wir uns den Einzeltag 29.03.2018 genau an, für den die Umsätze in den Warengruppen 1 und 3 für alle 5 naiven Modellen zu tief geschätzt wird.
## # A tibble: 10 x 63
## # Groups: Warengruppe [2]
## Datum Warengruppe Umsatz Jahr KielerWoche Bewoelkung Temperatur
## <date> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 2018-03-29 3 266. 2018 0 7 0.9
## 2 2018-03-29 1 370. 2018 0 7 0.9
## 3 2018-03-29 1 370. 2018 0 7 0.9
## 4 2018-03-29 3 266. 2018 0 7 0.9
## 5 2018-03-29 1 370. 2018 0 7 0.9
## 6 2018-03-29 3 266. 2018 0 7 0.9
## 7 2018-03-29 1 370. 2018 0 7 0.9
## 8 2018-03-29 3 266. 2018 0 7 0.9
## 9 2018-03-29 3 266. 2018 0 7 0.9
## 10 2018-03-29 1 370. 2018 0 7 0.9
## # ... with 56 more variables: Windgeschwindigkeit <dbl>, Wochentag <dbl>,
## # Monat <dbl>, Wochentag_c <chr>, Monat_c <chr>, Wochenende <dbl>,
## # SommerferienSH <dbl>, SommerferienNRW <dbl>, SommerferienNDS <dbl>,
## # SommerferienHE <dbl>, Feiertag <dbl>, Ostern <dbl>,
## # ChristiHimmelfahrt <dbl>, Pfingsten <dbl>, TDE <dbl>, Silvester <dbl>,
## # Ostern_ext <dbl>, ChristiHimmelfahrt_ext <dbl>, Pfingsten_ext <dbl>,
## # Silvester_ext <dbl>, Jahreszeit <chr>, Fruehling <dbl>, Sommer <dbl>,
## # Herbst <dbl>, Winter <dbl>, Umsatz_NA <lgl>, Umsatz_lag_1W <dbl>,
## # Umsatz_lag_2W <dbl>, Umsatz_lag_3W <dbl>, Umsatz_lag_4W <dbl>,
## # Umsatz_lag <dbl>, Umsatz_gewMW_4W <dbl>, Umsatz_lag_1T <dbl>,
## # Umsatz_lag_2T <dbl>, Umsatz_lag_3T <dbl>, Umsatz_lag_4T <dbl>,
## # Umsatz_lag_5T <dbl>, Umsatz_lag_6T <dbl>, Umsatz_lag_7T <dbl>,
## # Umsatz_lag_8T <dbl>, Umsatz_lag_13T <dbl>, Umsatz_lag_14T <dbl>,
## # Umsatz_glDS_3T <dbl>, Umsatz_glDS_3T_erw <dbl>, Umsatz_temp <dbl>,
## # Umsatz_glDS_4T_erw <dbl>, Prognose_zuhoch <lgl>, Abweichung <dbl>,
## # Abweichung_abs <dbl>, Abweichung_rel <dbl>, Abweichung_quad <dbl>,
## # Anzahl <int>, Abweichung_rel_abs <dbl>,
## # Abweichung_rel_abs_mult_umsatz <dbl>, Modell <chr>, Prognose <chr>
Und auch hier ist die Erklärung für den zu niedrig geschätzten Umsatz ein Feiertagseffekt: Beim 29.03.2018 handelt es sich um den Donnerstag vor Karfreitag.
Fazit naive Modelle
Wir stellen also insgesamt fest, dass unsere naiven Modelle die Umsätze auf Basis der jüngeren Vergangenheit schätzen. Stärkere Umsätze an oder vor Feiertagen werden nicht vorhergesagt und die Umsätze nach Feiertagen werden entsprechend zu hoch geschätzt.
Eine Verbesserung der naiven Modelle könnten wir erzielen, indem wir die Umsätze für Feiertage auf Basis der Vorjahreswerte schätzen. Das funktioniert naiv aber nur für Feiertage, die an festen Daten liegen, wie bspw. Silvester. Für Ostern funktioniert dieses naive Vorgehen nicht. Wir verzichten auf diese Modellerweiterung und widmen uns stattdessen im Folgenden statistischen Modellen und betrachten Machine Learning und Deep Learning Modelle.
6 Anwendung statistischer Modelle - Lineare Regression
6.1 Vorhaben
In einem nächsten Schritt wird mit der linearen Regression ein traditionelles statistisches Modell zur Prognose der Bäckereiumsätze eingesetzt. Die lineare Regression ist ein sehr einfacher Ansatz für das sog. “überwachte Lernen” (supervised learning). Lineare Regressionsmodelle sind insbesondere ein nützliches Werkzeug zur Vorhersage einer quantitativen Output-Variable, die in diesem Fall dem Umsatz pro Tag entspricht. Auch wenn die lineare Regression im Vergleich modernen statistischen Lernmethoden ein vergleichsweise einfaches Modell ist, ist sie immer noch weit verbreitet. Überdies dient sie als guter Ausgangspunkt für neuere Ansätze: viele neuere statistische Lernansätze können als Generalisierung oder Erweiterung der linearen Regression betrachtet werden.
Im Allgemeinen ist bei der linearen Regression zwischen der einfachen und der multiplen Regression zu unterscheiden. Während im ersten Fall nur eine einzelne Variable als Vorhersageparameter für die abhängige Variable betrachtet wird, werden bei der multiplen linearen Regression mehrere Input-Variablen in das Modell einbezogen. Da hinsichtlich der beeinflussenden Variablen Unterschiede bei den einzelnen Warengruppen zu erwarten sind, werden die Warengruppen isoliert betrachtet. Das heißt, für jede Warengruppe werden unterschiedliche Modelle angewendet und verglichen.
Insgesamt wird Vorgehen wird in mehreren Stufen untergliedert: Zunächst wird auf Basis des allumfassenden Datensatzes df_voll ein Datensatz für die Anwendung der linearen Modelle (df_lm) erstellt und dieser sodann in einen Trainings- und einen Testdatensatz aufgeteilt. In einem nächsten Schritt werden mittels sog. best subset selection und stepwise selection die in das Modell aufzunehmenden Variablen bestimmt und auf dieser Grundlage dann Regressionsmodelle erstellt.
6.2 Datenaufbereitung
Wir arbeiten mit dem vollständigen Datensatz df_voll. Dieser enthält im Zeitraum 01.07.2013 bis 31.07.2019 eine Zeile für jedes Datum und jede Warengruppe. In den Rohdaten fehlende Umsätze sind auf Basis der Vorwochenwerte ergänzt worden. Die Zeilen mit ergänzten Umsätzen sind selektierbar über die Variable Umsatz_NA (= TRUE).
Für unser Vorhaben beschränken wir uns auf die in den Rohdaten vorhandenen Umsätze (Umsatz_NA = FALSE). Und wir schränken die Trainingsdaten später auf den Zeitraum 2015 bis 2017 ein, weil wir oben gesehen hatten, dass die Umsätze in 2014 systematisch höher liegen als in den folgenden Jahren. Die Umsätze des Jahres 2018 dienen uns dann als Testdaten.
Wir erstellen für diesen Abschnitt einen Arbeitsdatensatz df_lm auf Basis von df_voll. Die nicht benötigten Umsatz-Spalten (Umsatz_NA sowie die Umsatz_lag Variablen) werden entfernt. Weiterhin werden Redundanzen eliminiert: der Datensatz enthält sowohl für die Monate als auch für die Wochentage jeweils eine numerische und eine character-Variable. Die numerischen sind für die linearen Modelle unbrauchbar, da dann den eigentlich nominalen Variablen Zahlenwerte zugeordnet würden, die im Rahmen der linearen Modelle auch interpretiert würden. Das würde dazu führen, dass bspw. der Dezember 12x so hoch / stark wie der Januar bewertet wird. Insofern werden die numerischen Variablen für Monat und Wochentag entfernt.
df_lm <- df_voll %>%
filter(Umsatz_NA == FALSE) %>%
select(-Umsatz_NA, -Umsatz_lag_1W, -Umsatz_lag_2W, -Umsatz_lag_3W, -Umsatz_lag_4W, -Umsatz_lag, -Wochentag, -Monat)
df_lm_train <- df_lm %>% filter(Jahr >= 2015 & Jahr <= 2017)
df_lm_train <- na.omit(df_lm_train)
df_lm_test <- df_lm %>% filter(Jahr == 2018)
df_lm_test <- na.omit(df_lm_test)6.2.1 Überprüfung auf lineare Abhängigkeiten der Variablen
Für die Erstellung linearer Modelle dürfen keine linearen Abhängigkeiten zwischen den einzelnen Variablen bestehen. Zunächst ist also zu prüfen, zwischen welchen Variablen lineare Abhängigkeiten bestehen:
## Model :
## Umsatz ~ Datum + Warengruppe + Jahr + KielerWoche + Bewoelkung +
## Temperatur + Windgeschwindigkeit + Wochentag_c + Monat_c +
## Wochenende + SommerferienSH + SommerferienNRW + SommerferienNDS +
## SommerferienHE + Feiertag + Ostern + ChristiHimmelfahrt +
## Pfingsten + TDE + Silvester + Ostern_ext + ChristiHimmelfahrt_ext +
## Pfingsten_ext + Silvester_ext + Jahreszeit + Fruehling +
## Sommer + Herbst + Winter
##
## Complete :
## (Intercept) Datum Warengruppe Jahr KielerWoche Bewoelkung
## Wochenende 0 0 0 0 0 0
## Silvester 0 0 0 0 0 0
## Fruehling 1 0 0 0 0 0
## Sommer 0 0 0 0 0 0
## Herbst 0 0 0 0 0 0
## Winter 0 0 0 0 0 0
## Temperatur Windgeschwindigkeit Wochentag_cDonnerstag
## Wochenende 0 0 0
## Silvester 0 0 0
## Fruehling 0 0 0
## Sommer 0 0 0
## Herbst 0 0 0
## Winter 0 0 0
## Wochentag_cFreitag Wochentag_cMittwoch Wochentag_cMontag
## Wochenende 0 0 0
## Silvester 0 0 0
## Fruehling 0 0 0
## Sommer 0 0 0
## Herbst 0 0 0
## Winter 0 0 0
## Wochentag_cSamstag Wochentag_cSonntag Monat_cAugust
## Wochenende 1 1 0
## Silvester 0 0 0
## Fruehling 0 0 0
## Sommer 0 0 0
## Herbst 0 0 0
## Winter 0 0 0
## Monat_cDezember Monat_cFebruar Monat_cJanuar Monat_cJuli
## Wochenende 0 0 0 0
## Silvester 0 0 0 0
## Fruehling 0 0 0 0
## Sommer 0 0 0 0
## Herbst 0 0 0 0
## Winter 0 0 0 0
## Monat_cJuni Monat_cMai Monat_cMärz Monat_cNovember
## Wochenende 0 0 0 0
## Silvester 0 0 0 0
## Fruehling 0 0 0 0
## Sommer 0 0 0 0
## Herbst 0 0 0 0
## Winter 0 0 0 0
## Monat_cOktober Monat_cSeptember SommerferienSH SommerferienNRW
## Wochenende 0 0 0 0
## Silvester 0 0 0 0
## Fruehling 0 0 0 0
## Sommer 0 0 0 0
## Herbst 0 0 0 0
## Winter 0 0 0 0
## SommerferienNDS SommerferienHE Feiertag Ostern
## Wochenende 0 0 0 0
## Silvester 0 0 1 -1
## Fruehling 0 0 0 0
## Sommer 0 0 0 0
## Herbst 0 0 0 0
## Winter 0 0 0 0
## ChristiHimmelfahrt Pfingsten TDE Ostern_ext
## Wochenende 0 0 0 0
## Silvester -1 -1 -1 0
## Fruehling 0 0 0 0
## Sommer 0 0 0 0
## Herbst 0 0 0 0
## Winter 0 0 0 0
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## Wochenende 0 0 0
## Silvester 0 0 0
## Fruehling 0 0 0
## Sommer 0 0 0
## Herbst 0 0 0
## Winter 0 0 0
## JahreszeitHerbst JahreszeitSommer JahreszeitWinter
## Wochenende 0 0 0
## Silvester 0 0 0
## Fruehling -1 -1 -1
## Sommer 0 1 0
## Herbst 1 0 0
## Winter 0 0 1
Um die linearen Abhängigkeiten zu eliminieren, werden Variablen entfernt:
df_lm_train <- df_lm_train %>%
select(-Fruehling, -Sommer, -Herbst, -Winter, - Wochenende, -Silvester)
df_lm_test <- df_lm_test %>%
select(-Fruehling, -Sommer, -Herbst, -Winter, -Wochenende, -Silvester)Erneute Überprüfung:
## Model :
## Umsatz ~ Datum + Warengruppe + Jahr + KielerWoche + Bewoelkung +
## Temperatur + Windgeschwindigkeit + Wochentag_c + Monat_c +
## SommerferienSH + SommerferienNRW + SommerferienNDS + SommerferienHE +
## Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE +
## Ostern_ext + ChristiHimmelfahrt_ext + Pfingsten_ext + Silvester_ext +
## Jahreszeit
6.2.3 Überprüfung auf Multikollinearität
Bei der multiplen Regression können zwei oder mehr Prädiktorvariablen miteinander korreliert sein. Diese Situation wird als Kollinearität bezeichnet.
Es gibt eine extreme Situation, die als Multikollinearität bezeichnet wird und in der Kollinearität zwischen drei oder mehr Variablen besteht, selbst wenn kein Variablenpaar eine besonders hohe Korrelation aufweist. Dies bedeutet, dass zwischen Prädiktorvariablen Redundanz besteht.
Bei Vorhandensein von Multikollinearität wird die Lösung des Regressionsmodells instabil.
Multikollinearität kann auf zwei verschiedene Arten überprüft werden:
- Zum einen kann die Multikollinearität für einen gegebenen Prädiktor (p) bewertet werden, indem ein Score berechnet wird, der als Varianzinflationsfaktor (oder VIF) bezeichnet wird und misst, wie stark die Varianz eines Regressionskoeffizienten aufgrund der Multikollinearität im Modell aufgeblasen wird,
- zum anderen anhand der Korrelationen der Variablen untereinander.
Der kleinstmögliche Wert von VIF ist eins (Fehlen von Multikollinearität). Als Faustregel gilt, dass ein VIF-Wert, der 5 oder 10 überschreitet, ein problematisches Maß an Kollinearität anzeigt (James et al. 2014).
Bei Multikollinearität sollten die betroffenen Variablen entfernt werden, da das Vorhandensein von Multikollinearität impliziert, dass die Informationen, die diese Variable über die Antwort liefert, bei Vorhandensein der anderen Variablen redundant sind (James et al. 2014, P. Bruce und Bruce (2017)).
Erstellung eines ersten Regressionsmodells
Um eine Überprüfung auf Multikollinearität durchzuführen, wird ein Regressionsmodell erstellt, das alle unabhängigen Variablen enthält:
## Loading required package: lattice
##
## Attaching package: 'caret'
## The following object is masked from 'package:purrr':
##
## lift
# Erstellung des Modells
model1 <- lm(Umsatz ~., data = df_lm_train)
# Vorhersagen
predictions <- model1 %>% predict(df_lm_test)
# Modellperformance
data.frame(
RMSE = RMSE(predictions, df_lm_test$Umsatz),
R2 = R2(predictions, df_lm_test$Umsatz)
)## RMSE R2
## 1 125.8987 0.1522406
Der \(R^2\)-Wert ist mit 0.152 noch vglw. niedrig; der \(RMSE\) beträgt über alle Warengruppen 125.9.
Überprüfung auf Multikollinearität
Überprüfung mittels VIF
Die R-Funktion vif() [car package] kann genutzt werden um Multikollinearität zu erkennen:
## GVIF Df GVIF^(1/(2*Df))
## Datum 1.437552e+03 1 37.915062
## Warengruppe 1.000025e+00 1 1.000013
## Jahr 1.295322e+03 1 35.990584
## KielerWoche 1.842369e+00 1 1.357339
## Bewoelkung 1.256308e+00 1 1.120851
## Temperatur 5.496606e+00 1 2.344484
## Windgeschwindigkeit 1.080170e+00 1 1.039312
## Wochentag_c 1.133806e+00 6 1.010520
## Monat_c 1.600820e+05 11 1.724094
## SommerferienSH 4.838550e+00 1 2.199670
## SommerferienNRW 3.639013e+00 1 1.907620
## SommerferienNDS 3.479206e+00 1 1.865263
## SommerferienHE 3.216061e+00 1 1.793338
## Feiertag 1.416233e+01 1 3.763287
## Ostern 6.441376e+00 1 2.537987
## ChristiHimmelfahrt 3.340415e+00 1 1.827680
## Pfingsten 6.198707e+00 1 2.489720
## TDE 3.119960e+00 1 1.766341
## Ostern_ext 2.365444e+00 1 1.538000
## ChristiHimmelfahrt_ext 1.466910e+00 1 1.211161
## Pfingsten_ext 2.150779e+00 1 1.466553
## Silvester_ext 2.189628e+00 1 1.479739
## Jahreszeit 2.858888e+02 3 2.566647
Der VIF-Wert für die Variablen Datum und Jahr sind sehr hoch (VIF = 37.915062 respektive 35.990584). Dies könnte problematisch sein. Insofern sollten die Variablen entfernt werden. Dies würde zu einem einfacheren Modell führen, ohne die Modellgenauigkeit zu beeinträchtigen, was gut ist.
Überprüfung durch Korrelation:
Die Korrelationen nach Pearson können in R einfach über den Befehl cor() berechnet werden. Hier sollte kein Wert größer als .7 sein.
df_lm_train %>%
dplyr::select(-Datum, -Warengruppe, -Umsatz, -Wochentag_c, -Monat_c, -Jahreszeit) %>%
cor()## Jahr KielerWoche Bewoelkung
## Jahr 1.0000000000 0.0037131195 0.040489848
## KielerWoche 0.0037131195 1.0000000000 -0.010169489
## Bewoelkung 0.0404898475 -0.0101694893 1.000000000
## Temperatur -0.0119105107 0.1714359550 -0.359296567
## Windgeschwindigkeit -0.0368626385 0.0003772206 0.042964334
## SommerferienSH 0.0057160210 -0.0575903882 -0.112608750
## SommerferienNRW 0.0058808588 -0.0597251953 -0.092520351
## SommerferienNDS 0.0014129652 0.0889933065 -0.023319475
## SommerferienHE 0.0011623913 -0.0562887744 -0.089544104
## Feiertag 0.0036382618 -0.0227375516 -0.011467063
## Ostern 0.0010499763 -0.0121258343 -0.001894188
## ChristiHimmelfahrt 0.0007413892 -0.0085620624 -0.040084695
## Pfingsten 0.0010499763 -0.0121258343 -0.016860067
## TDE 0.0007413892 -0.0085620624 -0.004859961
## Ostern_ext 0.0037176075 -0.0163057487 -0.014472937
## ChristiHimmelfahrt_ext 0.0016673042 -0.0192551538 -0.115495470
## Pfingsten_ext 0.0036834245 -0.0170520772 0.011485794
## Silvester_ext 0.0041710408 -0.0119208913 0.051747026
## Temperatur Windgeschwindigkeit SommerferienSH
## Jahr -0.011910511 -0.0368626385 0.005716021
## KielerWoche 0.171435955 0.0003772206 -0.057590388
## Bewoelkung -0.359296567 0.0429643338 -0.112608750
## Temperatur 1.000000000 -0.0120645003 0.424235994
## Windgeschwindigkeit -0.012064500 1.0000000000 -0.039982599
## SommerferienSH 0.424235994 -0.0399825988 1.000000000
## SommerferienNRW 0.442095183 -0.0203412230 0.663904053
## SommerferienNDS 0.415536926 -0.0301218240 0.407233003
## SommerferienHE 0.424282177 -0.0578527211 0.672564795
## Feiertag -0.008045139 0.0336145412 -0.050783590
## Ostern -0.038164531 0.0055246913 -0.027082661
## ChristiHimmelfahrt 0.025126030 0.0081566874 -0.019123091
## Pfingsten 0.024712144 0.0085382110 -0.027082661
## TDE 0.019752296 0.0336908750 -0.019123091
## Ostern_ext -0.050832958 0.0601092060 -0.036418365
## ChristiHimmelfahrt_ext 0.088386968 0.0393988405 -0.043005767
## Pfingsten_ext 0.037386236 0.0070508831 -0.038085266
## Silvester_ext -0.078694007 0.0062485820 -0.026624927
## SommerferienNRW SommerferienNDS SommerferienHE
## Jahr 0.005880859 0.001412965 0.001162391
## KielerWoche -0.059725195 0.088993306 -0.056288774
## Bewoelkung -0.092520351 -0.023319475 -0.089544104
## Temperatur 0.442095183 0.415536926 0.424282177
## Windgeschwindigkeit -0.020341223 -0.030121824 -0.057852721
## SommerferienSH 0.663904053 0.407233003 0.672564795
## SommerferienNRW 1.000000000 0.405753907 0.571878261
## SommerferienNDS 0.405753907 1.000000000 0.665698954
## SommerferienHE 0.571878261 0.665698954 1.000000000
## Feiertag -0.052666077 -0.051257648 -0.049635818
## Ostern -0.028086583 -0.027335474 -0.026470559
## ChristiHimmelfahrt -0.019831961 -0.019301602 -0.018690886
## Pfingsten -0.028086583 -0.027335474 -0.026470559
## TDE -0.019831961 -0.019301602 -0.018690886
## Ostern_ext -0.037768351 -0.036758326 -0.035595265
## ChristiHimmelfahrt_ext -0.044599939 -0.043407220 -0.042033783
## Pfingsten_ext -0.039497041 -0.038440787 -0.037224492
## Silvester_ext -0.027611882 -0.026873467 -0.026023171
## Feiertag Ostern ChristiHimmelfahrt
## Jahr 0.003638262 0.001049976 0.0007413892
## KielerWoche -0.022737552 -0.012125834 -0.0085620624
## Bewoelkung -0.011467063 -0.001894188 -0.0400846950
## Temperatur -0.008045139 -0.038164531 0.0251260295
## Windgeschwindigkeit 0.033614541 0.005524691 0.0081566874
## SommerferienSH -0.050783590 -0.027082661 -0.0191230910
## SommerferienNRW -0.052666077 -0.028086583 -0.0198319611
## SommerferienNDS -0.051257648 -0.027335474 -0.0193016024
## SommerferienHE -0.049635818 -0.026470559 -0.0186908855
## Feiertag 1.000000000 0.533295514 0.3765604380
## Ostern 0.533295514 1.000000000 -0.0040264259
## ChristiHimmelfahrt 0.376560438 -0.004026426 1.0000000000
## Pfingsten 0.533295514 -0.005702338 -0.0040264259
## TDE 0.376560438 -0.004026426 -0.0028430629
## Ostern_ext 0.392014329 0.743653940 -0.0054143812
## ChristiHimmelfahrt_ext 0.155785294 -0.009054997 0.4446634116
## Pfingsten_ext 0.373940746 -0.008018970 -0.0056622022
## Silvester_ext 0.247664503 -0.005605961 -0.0039583739
## Pfingsten TDE Ostern_ext
## Jahr 0.001049976 0.0007413892 0.003717608
## KielerWoche -0.012125834 -0.0085620624 -0.016305749
## Bewoelkung -0.016860067 -0.0048599614 -0.014472937
## Temperatur 0.024712144 0.0197522958 -0.050832958
## Windgeschwindigkeit 0.008538211 0.0336908750 0.060109206
## SommerferienSH -0.027082661 -0.0191230910 -0.036418365
## SommerferienNRW -0.028086583 -0.0198319611 -0.037768351
## SommerferienNDS -0.027335474 -0.0193016024 -0.036758326
## SommerferienHE -0.026470559 -0.0186908855 -0.035595265
## Feiertag 0.533295514 0.3765604380 0.392014329
## Ostern -0.005702338 -0.0040264259 0.743653940
## ChristiHimmelfahrt -0.004026426 -0.0028430629 -0.005414381
## Pfingsten 1.000000000 -0.0040264259 -0.007667999
## TDE -0.004026426 1.0000000000 -0.005414381
## Ostern_ext -0.007667999 -0.0054143812 1.000000000
## ChristiHimmelfahrt_ext -0.009054997 -0.0063937415 -0.012176359
## Pfingsten_ext 0.711105992 -0.0056622022 -0.010783202
## Silvester_ext -0.005605961 -0.0039583739 -0.007538400
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## Jahr 0.001667304 0.003683425 0.004171041
## KielerWoche -0.019255154 -0.017052077 -0.011920891
## Bewoelkung -0.115495470 0.011485794 0.051747026
## Temperatur 0.088386968 0.037386236 -0.078694007
## Windgeschwindigkeit 0.039398841 0.007050883 0.006248582
## SommerferienSH -0.043005767 -0.038085266 -0.026624927
## SommerferienNRW -0.044599939 -0.039497041 -0.027611882
## SommerferienNDS -0.043407220 -0.038440787 -0.026873467
## SommerferienHE -0.042033783 -0.037224492 -0.026023171
## Feiertag 0.155785294 0.373940746 0.247664503
## Ostern -0.009054997 -0.008018970 -0.005605961
## ChristiHimmelfahrt 0.444663412 -0.005662202 -0.003958374
## Pfingsten -0.009054997 0.711105992 -0.005605961
## TDE -0.006393742 -0.005662202 -0.003958374
## Ostern_ext -0.012176359 -0.010783202 -0.007538400
## ChristiHimmelfahrt_ext 1.000000000 -0.012733681 -0.008901955
## Pfingsten_ext -0.012733681 1.000000000 -0.007883439
## Silvester_ext -0.008901955 -0.007883439 1.000000000
Einige der unabhängigen Variablen weisen starke bis mittelstarke Korrelationen auf (auf 3 Stellen gerundet):
- SommerferienSH und SommerferienNRW: 0.663904053
- SommerferienNRW und SommerferienHE: 0.571878261
- SommerferienSH und SommerferienHE: 0.672564795
- SommerferienNDS und SommerferienHE: 0.665698954
- Feiertag und Ostern: 0.533295514
- Feiertag und Pfingsten: 0.533295514
- Ostern und Ostern_ext: 0.743653940
- Pfingsten und Pfingsten_ext: 0.711105992
Da die Einflussvariablen mitunter stark korrelieren und die Grenze von .7 teilweise fast ankratzen und teilweise überschreiten, muss in Erwägung gezogen werden, auch einige der stark miteinander korrelierten Variablen zu eliminieren, da bspw. die schrittweise Regression bei Multikollinearität versagt. Zunächst werden die Tatsache, dass einzelne Variablen stark untereinander korrelieren, jedoch ignoriert. Eine sich doch als notwendig abzeichnende Eliminierung weiterer Variablen erfolgt ggf. zu einem späteren Zeitpunkt.
Umgang mit Multikollinearität
In diesem Abschnitt, wird das Modell erneut erstellt. Dieses Mal zunächst nur ohne die beiden problematischen Variablen Datum und Jahr.
df_lm_train <- df_lm_train %>% select(-Datum, -Jahr)
df_lm_test <- df_lm_test %>% select(-Datum, -Jahr)
# Modellbildung ohne die beiden Variablen
model2 <- lm(Umsatz ~., data = df_lm_train)
# Make predictions
predictions <- model2 %>% predict(df_lm_test)
# Model performance
data.frame(
RMSE = RMSE(predictions, df_lm_test$Umsatz),
R2 = R2(predictions, df_lm_test$Umsatz)
)## RMSE R2
## 1 124.2938 0.1524634
Man kann sehen, dass das Entfernen der beiden Variablen Datum und Jahr die Modellleistungsmetriken nicht sehr beeinflusst (RMSE inkl. Datum und Jahr: 125.8987, R2: 0.1522406). Mit anderen Worten, die Modellgenauigkeit leidet nur marginal unter dem Entfernen der beiden Variablen.
6.3 Erstellung linearer Regressionsmodelle für die einzelnen Warengruppen
Laden der benötigten Pakete
Wir beginnen unsere Analyse mit dem Laden der notwendigen Pakete, die bislang noch nicht geladen wurden:
caretfür einen einfachen Machine Learning workflowleapsfür die Berechnung einer schrittweisen Regression
6.3.1 Warengruppe 1
Erstellung von Trainings- und Testdatensätzen für Warengruppe 1
df_lm_train_WG1 <- df_lm_train %>% filter(Warengruppe == "1")
df_lm_train_WG1 <- na.omit(df_lm_train_WG1)
df_lm_train_WG1 <- df_lm_train_WG1 %>% dplyr::select(-Warengruppe)
df_lm_test_WG1 <- df_lm_test %>% filter(Warengruppe == "1")
df_lm_test_WG1 <- na.omit(df_lm_test_WG1)
df_lm_test_WG1 <- df_lm_test_WG1 %>% dplyr::select(-Warengruppe)Auswahl der am besten geeigneten Variablen
Beste Teilmengenauswahl (“Best subset selection”)
Um die beste Teilmengenauswahl durchzuführen, passen wir für jede mögliche Kombination der \(p\) Prädiktoren eine separate Regression der kleinsten Quadrate an. Das heißt, wir passen alle \(p\)-Modelle an, die genau einen Prädiktor enthalten, alle \(\binom{p}{2} = p (p - 1) / 2\)-Modelle, die genau zwei Prädiktoren enthalten, und so weiter. Wir betrachten dann alle resultierenden Modelle mit dem Ziel, das beste zu identifizieren.
Der dreistufige Prozess zur Durchführung der Auswahl der besten Teilmenge umfasst:
Schritt 1: Bezeichne \(M_0\) das Nullmodell, das keine Prädiktoren enthält. Dieses Modell sagt einfach den Stichprobenmittelwert für jede Beobachtung voraus.
Schritt 2: Für \(k = 1,2,… p\):
- Passe alle \(\binom{p}{k}\) Modelle an, die genau \(k\) Prädiktoren enthalten.
- Wähle die besten unter diesen \(\binom{p}{k}\) Modelle, und nenne es \(M_{k}\). Hier wird “beste Modelle” in der Form definiert, dass diese die kleinsten RSS (residual sum of squares, Quadratssumme der Residuen) oder äquivalent die größten \(R^2\)-Werte haben.
Schritt 3: Wähle aus \(M_0, .. , M_p\) ein einzelnes bestes Modell aus unter Verwendung eines kreuzvalidierten Vorhersagefehlers (cross validated prediction error), \(Cp\), \(AIC\), \(BIC\) oder adjustiertem \(R^2\).
Die Suche nach den besten Teilmengen an Prädikatorvariablen kann mithilfe von regsubsets (Teil der leaps-Bibliothek) durchgeführt werden. regsubsets identifiziert das beste Modell für eine bestimmte/festgelegte Anzahl von k Prädiktoren, wobei “das Beste” mithilfe der RSS quantifiziert wird. Die Syntax entspricht der lm-Funktion. Standardmäßig meldet regsubsets nur Ergebnisse bis zum besten Modell mit acht Variablen. Die Option nvmax kann jedoch verwendet werden, um so viele Variablen wie gewünscht zurückzugeben. Hier passen wir zu einem Modell mit 37 Variablen.
Die regsubsets-Funktion gibt ein Listenobjekt mit vielen Informationen zurück. Zunächst kann der Befehl summary verwendet werden, um den besten Satz von Variablen für jede Modellgröße zu ermitteln.
## Subset selection object
## Call: regsubsets.formula(Umsatz ~ ., df_lm_train_WG1, nvmax = 37)
## 37 Variables (and intercept)
## Forced in Forced out
## KielerWoche FALSE FALSE
## Bewoelkung FALSE FALSE
## Temperatur FALSE FALSE
## Windgeschwindigkeit FALSE FALSE
## Wochentag_cDonnerstag FALSE FALSE
## Wochentag_cFreitag FALSE FALSE
## Wochentag_cMittwoch FALSE FALSE
## Wochentag_cMontag FALSE FALSE
## Wochentag_cSamstag FALSE FALSE
## Wochentag_cSonntag FALSE FALSE
## Monat_cAugust FALSE FALSE
## Monat_cDezember FALSE FALSE
## Monat_cFebruar FALSE FALSE
## Monat_cJanuar FALSE FALSE
## Monat_cJuli FALSE FALSE
## Monat_cJuni FALSE FALSE
## Monat_cMai FALSE FALSE
## Monat_cMärz FALSE FALSE
## Monat_cNovember FALSE FALSE
## Monat_cOktober FALSE FALSE
## Monat_cSeptember FALSE FALSE
## SommerferienSH FALSE FALSE
## SommerferienNRW FALSE FALSE
## SommerferienNDS FALSE FALSE
## SommerferienHE FALSE FALSE
## Feiertag FALSE FALSE
## Ostern FALSE FALSE
## ChristiHimmelfahrt FALSE FALSE
## Pfingsten FALSE FALSE
## TDE FALSE FALSE
## Ostern_ext FALSE FALSE
## ChristiHimmelfahrt_ext FALSE FALSE
## Pfingsten_ext FALSE FALSE
## Silvester_ext FALSE FALSE
## JahreszeitHerbst FALSE FALSE
## JahreszeitSommer FALSE FALSE
## JahreszeitWinter FALSE FALSE
## 1 subsets of each size up to 37
## Selection Algorithm: exhaustive
## KielerWoche Bewoelkung Temperatur Windgeschwindigkeit
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " "*" " "
## 8 ( 1 ) " " " " "*" " "
## 9 ( 1 ) " " " " "*" " "
## 10 ( 1 ) " " " " "*" " "
## 11 ( 1 ) " " " " "*" " "
## 12 ( 1 ) " " " " "*" " "
## 13 ( 1 ) " " " " "*" " "
## 14 ( 1 ) " " " " "*" " "
## 15 ( 1 ) " " " " " " " "
## 16 ( 1 ) " " " " " " " "
## 17 ( 1 ) " " " " " " " "
## 18 ( 1 ) " " " " " " " "
## 19 ( 1 ) " " " " " " " "
## 20 ( 1 ) "*" " " " " " "
## 21 ( 1 ) "*" " " " " " "
## 22 ( 1 ) "*" " " " " " "
## 23 ( 1 ) "*" " " " " " "
## 24 ( 1 ) "*" " " " " " "
## 25 ( 1 ) "*" " " " " " "
## 26 ( 1 ) "*" " " " " " "
## 27 ( 1 ) "*" " " " " " "
## 28 ( 1 ) "*" "*" "*" " "
## 29 ( 1 ) "*" "*" "*" " "
## 30 ( 1 ) "*" "*" "*" " "
## 31 ( 1 ) "*" "*" "*" " "
## 32 ( 1 ) "*" "*" "*" " "
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## Wochentag_cDonnerstag Wochentag_cFreitag Wochentag_cMittwoch
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " "*"
## 9 ( 1 ) " " " " "*"
## 10 ( 1 ) "*" "*" " "
## 11 ( 1 ) "*" "*" " "
## 12 ( 1 ) "*" "*" " "
## 13 ( 1 ) "*" "*" " "
## 14 ( 1 ) "*" "*" " "
## 15 ( 1 ) "*" "*" " "
## 16 ( 1 ) "*" "*" " "
## 17 ( 1 ) "*" "*" " "
## 18 ( 1 ) "*" "*" " "
## 19 ( 1 ) "*" "*" " "
## 20 ( 1 ) "*" "*" " "
## 21 ( 1 ) "*" "*" " "
## 22 ( 1 ) "*" "*" " "
## 23 ( 1 ) "*" "*" " "
## 24 ( 1 ) "*" "*" " "
## 25 ( 1 ) "*" "*" " "
## 26 ( 1 ) "*" "*" " "
## 27 ( 1 ) "*" "*" " "
## 28 ( 1 ) "*" "*" " "
## 29 ( 1 ) "*" "*" " "
## 30 ( 1 ) "*" "*" "*"
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
## Wochentag_cMontag Wochentag_cSamstag Wochentag_cSonntag
## 1 ( 1 ) " " " " "*"
## 2 ( 1 ) " " " " "*"
## 3 ( 1 ) " " " " "*"
## 4 ( 1 ) " " " " "*"
## 5 ( 1 ) " " "*" "*"
## 6 ( 1 ) " " "*" "*"
## 7 ( 1 ) " " "*" "*"
## 8 ( 1 ) " " "*" "*"
## 9 ( 1 ) " " "*" "*"
## 10 ( 1 ) "*" "*" "*"
## 11 ( 1 ) "*" "*" "*"
## 12 ( 1 ) "*" "*" "*"
## 13 ( 1 ) "*" "*" "*"
## 14 ( 1 ) "*" "*" "*"
## 15 ( 1 ) "*" "*" "*"
## 16 ( 1 ) "*" "*" "*"
## 17 ( 1 ) "*" "*" "*"
## 18 ( 1 ) "*" "*" "*"
## 19 ( 1 ) "*" "*" "*"
## 20 ( 1 ) "*" "*" "*"
## 21 ( 1 ) "*" "*" "*"
## 22 ( 1 ) "*" "*" "*"
## 23 ( 1 ) "*" "*" "*"
## 24 ( 1 ) "*" "*" "*"
## 25 ( 1 ) "*" "*" "*"
## 26 ( 1 ) "*" "*" "*"
## 27 ( 1 ) "*" "*" "*"
## 28 ( 1 ) "*" "*" "*"
## 29 ( 1 ) "*" "*" "*"
## 30 ( 1 ) "*" "*" "*"
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
## Monat_cAugust Monat_cDezember Monat_cFebruar Monat_cJanuar
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " " " " "
## 8 ( 1 ) " " " " " " " "
## 9 ( 1 ) " " " " " " " "
## 10 ( 1 ) " " " " " " " "
## 11 ( 1 ) " " " " " " " "
## 12 ( 1 ) " " " " " " " "
## 13 ( 1 ) " " " " " " " "
## 14 ( 1 ) " " " " " " " "
## 15 ( 1 ) " " " " "*" "*"
## 16 ( 1 ) " " " " "*" "*"
## 17 ( 1 ) " " " " "*" "*"
## 18 ( 1 ) " " " " "*" "*"
## 19 ( 1 ) " " " " "*" "*"
## 20 ( 1 ) " " " " "*" "*"
## 21 ( 1 ) " " " " "*" "*"
## 22 ( 1 ) " " " " "*" "*"
## 23 ( 1 ) " " " " "*" "*"
## 24 ( 1 ) " " " " "*" "*"
## 25 ( 1 ) " " "*" "*" "*"
## 26 ( 1 ) " " "*" "*" "*"
## 27 ( 1 ) " " "*" "*" "*"
## 28 ( 1 ) " " " " "*" "*"
## 29 ( 1 ) " " "*" "*" "*"
## 30 ( 1 ) " " "*" "*" "*"
## 31 ( 1 ) " " "*" "*" "*"
## 32 ( 1 ) " " "*" "*" "*"
## 33 ( 1 ) " " "*" "*" "*"
## 34 ( 1 ) " " "*" "*" "*"
## 35 ( 1 ) " " "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## Monat_cJuli Monat_cJuni Monat_cMai Monat_cMärz Monat_cNovember
## 1 ( 1 ) " " " " " " " " " "
## 2 ( 1 ) " " " " " " " " " "
## 3 ( 1 ) " " " " " " " " " "
## 4 ( 1 ) " " " " " " " " " "
## 5 ( 1 ) " " " " " " " " " "
## 6 ( 1 ) " " " " " " " " " "
## 7 ( 1 ) " " " " " " " " " "
## 8 ( 1 ) " " " " " " " " " "
## 9 ( 1 ) " " " " " " " " " "
## 10 ( 1 ) " " " " " " " " " "
## 11 ( 1 ) " " " " " " " " " "
## 12 ( 1 ) " " " " " " " " " "
## 13 ( 1 ) " " " " " " " " " "
## 14 ( 1 ) " " " " " " " " " "
## 15 ( 1 ) " " " " " " " " " "
## 16 ( 1 ) " " " " " " " " " "
## 17 ( 1 ) " " " " " " " " " "
## 18 ( 1 ) " " " " " " "*" " "
## 19 ( 1 ) " " " " " " "*" " "
## 20 ( 1 ) " " " " " " " " " "
## 21 ( 1 ) " " " " " " " " " "
## 22 ( 1 ) " " " " " " "*" " "
## 23 ( 1 ) " " " " " " "*" " "
## 24 ( 1 ) " " " " " " "*" " "
## 25 ( 1 ) " " " " " " " " "*"
## 26 ( 1 ) " " " " " " "*" "*"
## 27 ( 1 ) " " " " " " "*" "*"
## 28 ( 1 ) " " " " " " "*" " "
## 29 ( 1 ) " " " " " " "*" "*"
## 30 ( 1 ) " " " " " " "*" "*"
## 31 ( 1 ) " " "*" " " "*" "*"
## 32 ( 1 ) " " "*" " " "*" "*"
## 33 ( 1 ) " " "*" " " "*" "*"
## 34 ( 1 ) " " "*" " " "*" "*"
## 35 ( 1 ) " " "*" "*" "*" "*"
## 36 ( 1 ) " " "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*" "*"
## Monat_cOktober Monat_cSeptember SommerferienSH SommerferienNRW
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " "*" " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " "*" " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " "*" " "
## 8 ( 1 ) " " " " "*" " "
## 9 ( 1 ) " " " " "*" " "
## 10 ( 1 ) " " " " "*" " "
## 11 ( 1 ) " " " " "*" " "
## 12 ( 1 ) " " " " "*" " "
## 13 ( 1 ) " " " " "*" " "
## 14 ( 1 ) " " " " "*" " "
## 15 ( 1 ) " " " " "*" " "
## 16 ( 1 ) "*" " " "*" " "
## 17 ( 1 ) "*" " " "*" " "
## 18 ( 1 ) "*" " " "*" " "
## 19 ( 1 ) "*" " " "*" "*"
## 20 ( 1 ) "*" "*" "*" "*"
## 21 ( 1 ) "*" "*" "*" "*"
## 22 ( 1 ) "*" "*" "*" "*"
## 23 ( 1 ) "*" "*" "*" "*"
## 24 ( 1 ) "*" "*" "*" "*"
## 25 ( 1 ) "*" "*" "*" "*"
## 26 ( 1 ) "*" "*" "*" "*"
## 27 ( 1 ) "*" "*" "*" "*"
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## SommerferienNDS SommerferienHE Feiertag Ostern
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " "*"
## 4 ( 1 ) " " " " " " "*"
## 5 ( 1 ) " " " " " " "*"
## 6 ( 1 ) " " " " " " "*"
## 7 ( 1 ) " " " " " " "*"
## 8 ( 1 ) " " " " " " "*"
## 9 ( 1 ) " " " " " " "*"
## 10 ( 1 ) " " " " " " "*"
## 11 ( 1 ) " " " " " " "*"
## 12 ( 1 ) " " " " " " "*"
## 13 ( 1 ) " " " " "*" "*"
## 14 ( 1 ) "*" " " "*" "*"
## 15 ( 1 ) " " " " "*" "*"
## 16 ( 1 ) " " " " "*" "*"
## 17 ( 1 ) "*" " " "*" "*"
## 18 ( 1 ) "*" " " "*" "*"
## 19 ( 1 ) "*" " " "*" "*"
## 20 ( 1 ) "*" " " "*" "*"
## 21 ( 1 ) "*" " " "*" "*"
## 22 ( 1 ) "*" " " "*" "*"
## 23 ( 1 ) "*" " " "*" "*"
## 24 ( 1 ) "*" " " "*" "*"
## 25 ( 1 ) "*" " " "*" "*"
## 26 ( 1 ) "*" " " "*" "*"
## 27 ( 1 ) "*" "*" "*" "*"
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## ChristiHimmelfahrt Pfingsten TDE Ostern_ext
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " "*"
## 4 ( 1 ) " " " " " " "*"
## 5 ( 1 ) " " " " " " "*"
## 6 ( 1 ) " " " " " " "*"
## 7 ( 1 ) " " " " " " "*"
## 8 ( 1 ) " " " " " " "*"
## 9 ( 1 ) " " " " "*" "*"
## 10 ( 1 ) " " " " " " "*"
## 11 ( 1 ) "*" " " " " "*"
## 12 ( 1 ) "*" " " "*" "*"
## 13 ( 1 ) "*" "*" "*" "*"
## 14 ( 1 ) "*" "*" "*" "*"
## 15 ( 1 ) "*" "*" "*" "*"
## 16 ( 1 ) "*" "*" "*" "*"
## 17 ( 1 ) "*" "*" "*" "*"
## 18 ( 1 ) "*" "*" "*" "*"
## 19 ( 1 ) "*" "*" "*" "*"
## 20 ( 1 ) "*" "*" "*" "*"
## 21 ( 1 ) "*" "*" "*" "*"
## 22 ( 1 ) "*" "*" "*" "*"
## 23 ( 1 ) "*" "*" "*" "*"
## 24 ( 1 ) "*" "*" "*" "*"
## 25 ( 1 ) "*" "*" "*" "*"
## 26 ( 1 ) "*" "*" "*" "*"
## 27 ( 1 ) "*" "*" "*" "*"
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " "*"
## 7 ( 1 ) " " " " "*"
## 8 ( 1 ) " " " " "*"
## 9 ( 1 ) " " " " "*"
## 10 ( 1 ) " " " " "*"
## 11 ( 1 ) " " " " "*"
## 12 ( 1 ) " " " " "*"
## 13 ( 1 ) " " " " " "
## 14 ( 1 ) " " " " " "
## 15 ( 1 ) " " " " " "
## 16 ( 1 ) " " " " " "
## 17 ( 1 ) " " " " " "
## 18 ( 1 ) " " " " " "
## 19 ( 1 ) " " " " " "
## 20 ( 1 ) " " " " " "
## 21 ( 1 ) " " "*" " "
## 22 ( 1 ) " " " " " "
## 23 ( 1 ) " " "*" " "
## 24 ( 1 ) " " "*" " "
## 25 ( 1 ) "*" "*" " "
## 26 ( 1 ) "*" "*" " "
## 27 ( 1 ) "*" "*" " "
## 28 ( 1 ) "*" "*" " "
## 29 ( 1 ) "*" "*" " "
## 30 ( 1 ) "*" "*" " "
## 31 ( 1 ) "*" "*" " "
## 32 ( 1 ) "*" "*" " "
## 33 ( 1 ) "*" "*" " "
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
## JahreszeitHerbst JahreszeitSommer JahreszeitWinter
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " "*" " "
## 6 ( 1 ) " " "*" " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " " "
## 9 ( 1 ) " " " " " "
## 10 ( 1 ) " " " " " "
## 11 ( 1 ) " " " " " "
## 12 ( 1 ) " " " " " "
## 13 ( 1 ) " " " " " "
## 14 ( 1 ) " " " " " "
## 15 ( 1 ) "*" " " " "
## 16 ( 1 ) "*" " " " "
## 17 ( 1 ) "*" " " " "
## 18 ( 1 ) "*" " " " "
## 19 ( 1 ) "*" " " " "
## 20 ( 1 ) "*" " " " "
## 21 ( 1 ) "*" " " " "
## 22 ( 1 ) "*" "*" " "
## 23 ( 1 ) "*" "*" " "
## 24 ( 1 ) "*" "*" "*"
## 25 ( 1 ) "*" "*" " "
## 26 ( 1 ) "*" "*" " "
## 27 ( 1 ) "*" "*" " "
## 28 ( 1 ) "*" "*" "*"
## 29 ( 1 ) "*" "*" " "
## 30 ( 1 ) "*" "*" " "
## 31 ( 1 ) "*" "*" " "
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
Für ein Modell mit einer Variablen kann beobachtet werden, dass die erzeugte Dummy-Variable Wochentag_cSonntag ein Sternchen hat, was signalisiert, dass ein Regressionsmodell mit Umsatz ~ Wochentag_cSonntag das beste Einzelvariablenmodell ist. Das beste 2-Variablen-Modell ist Umsatz ~ Wochentag_cSonntag + SommerferienSH. Das beste 3-Variablen-Modell ist Umsatz ~ Wochentag_cSonntag + Ostern + Ostern_ext. Und so weiter.
Man kann auch \(RSS\), \(R^2\), adjustiertes \(R^2\), \(C_{p}\) und \(BIC\) aus den Ergebnissen abrufen, um das beste Gesamtmodell zu bewerten. Dies wird jedoch im Abschnitt zum Vergleichen von Modellen veranschaulicht. Schauen wir uns zunächst an, wie die schrittweise Auswahl durchgeführt wird.
Schrittweise Auswahl (“Stepwise selection”)
Aus rechnerischen Gründen kann die beste Teilmengenauswahl nicht angewendet werden, wenn die Anzahl der \(p\) Prädiktorvariablen groß ist. Die Auswahl der besten Teilmenge kann auch unter statistischen Problemen leiden, wenn \(p\) groß ist. Je größer der Suchraum ist, desto höher ist die Wahrscheinlichkeit, Modelle zu finden, die auf den Trainingsdaten gut performen, auch wenn sie möglicherweise keine Vorhersagekraft für zukünftige Daten haben. Ein enormer Suchraum kann daher zu einer Überanpassung und einer hohen Varianz der Koeffizientenschätzungen führen. Aus diesen beiden Gründen sind schrittweise Methoden, die einen weitaus eingeschränkteren Satz von Modellen untersuchen, attraktive Alternativen zur Auswahl der besten Teilmenge.
Vorwärtsauswahl
Die schrittweise Vorwärtsauswahl beginnt mit einem Modell, das keine Prädiktoren enthält und fügt dem Modell dann nacheinander Prädiktoren hinzu, bis alle Prädiktoren im Modell enthalten sind. Insbesondere wird bei jedem Schritt die Variable zum Modell hinzugefügt, die die größte zusätzliche Verbesserung der Anpassung bewirkt.
Der dreistufige Prozess der schrittweisen Vorauswahl umfasst:
Schritt 1: Bezeichne \(M_{0}\) das Nullmodell, das keine Prädiktoren enthält. Dieses Modell sagt einfach den Stichprobenmittelwert für jede Beobachtung voraus.
Schritt 2: Für \(k = 0,…, p - 1\):
- Betrachte alle \(p - k\)- Modelle, die die Prädiktoren in \(M_{k}\) mit einem zusätzlichen Prädiktor erweitern.
- Wähle das beste unter diesen \(p - k\)-Modellen aus und nenne es \(M_{k+1}\). Hier wird das beste Modell als das mit dem kleinsten \(RSS\) oder dem höchstes \(R^2\) definiert.
Schritt 3: Wähle aus \(M_{0},..., M_{p}\) unter Verwendung eines kreuzvalidierten Vorhersagefehlers, \(C_{p}\), \(AIC\), \(BIC\) oder dem adjustierten \(R^2\) ein einzelnes bestes Modell aus.
Die schrittweise Vorwärtsauswahl kann mit regsubsets durchgeführt werden, indem die method = "forward" gesetzt wird:
Schrittweise rückwärts (Backward stepwise)
Die schrittweise Rückwärtsauswahl bietet eine effiziente Alternative zur Auswahl der besten Teilmenge. Im Gegensatz zur schrittweisen Vorwärtsauswahl beginnt sie jedoch mit dem vollständigen Modell der kleinsten Quadrate, das alle \(p\) Prädiktoren enthält, und entfernt dann nacheinander iterativ den am wenigsten nützlichen Prädiktor.
Der dreistufige Prozess der schrittweisen Vorauswahl umfasst:
Schritt 1: Bezeichne \(M_p\) das vollständige Modell, das alle p Prädiktoren enthält.
Schritt 2: Für \(k = p, p - 1,..., 1\)
Betrachte alle \(k\) Modelle, die alle bis auf einen der Prädiktoren in \(M_{k}\) enthalten für insgesamt \(k - 1\) Prädiktoren.
Wähle das beste unter den \(k\) Modellen aus und nenne es \(M_{k-1}\). Hier wird das beste Modell als das mit den kleinsten \(RSS\) oder den höchsten \(R^2\) definiert.
Schritt 3: Wähle aus \(M_{0},…, M_{p}\) ein einzelnes bestes Modell aus unter Verwendung eines kreuzvalidierten Vorhersagefehlers, \(C_{p}\), \(AIC\), \(BIC\) oder adjustiertem \(R^2\).
Die schrittweise Vorwärtsauswahl kann mit regsubsets durchgeführt werden, indem die method = "backward" gesetzt wird:
Modellauswahl
Bisher wurde gezeigt, wie die besten Teilmengen (Best Subset Selection) und schrittweisen Verfahren ausgeführt werden. In einem nächsten Schritt wird nun betrachtet, wie alle Modelle verglichen werden können, um das beste Modell zu ermitteln.
Um das beste Modell in Bezug auf den Testfehler auszuwählen, müssen wir diesen Testfehler schätzen. Es gibt zwei gängige Ansätze:
- Der Testfehler kann indirekt geschätzt werden, indem der Trainingsfehler angepasst wird, um die Verzerrung aufgrund von Überanpassung (Overfitting) zu berücksichtigen.
- Der Testfehler kann direkt abgeschätzt werden, indem entweder ein Validierungssatzansatz oder einen Kreuzvalidierungsansatz verwendet wird.
Wir betrachten im Folgenden beide Ansätze.
Indirekte Schätzung des Testfehlers mit \(C_{p}\), \(AIC\), \(BIC\) und adjustiertem \(R^2\)
Bei der Durchführung der Ansätze “beste Teilmenge” oder schrittweisen Annäherung werden die ausgewählten Modelle \(M_0,…, M_p\) basierend auf der Tatsache ausgewählt, dass sie den mittleren quadratischen Fehler (MSE) des Trainingssatzes minimieren. Aus diesem Grund und aufgrund der Tatsache, dass die Verwendung der Trainings-\(MSE\) und \(R^2\) unsere Ergebnisse beeinflusst, sollten wir diese Statistiken nicht verwenden, um zu bestimmen, welche der \(M_0,…, M_p\) Modelle “das Beste” ist.
Es stehen jedoch eine Reihe von Techniken zum Anpassen des Trainingsfehlers an die Modellgröße zur Verfügung. Diese Ansätze können verwendet werden, um aus einer Reihe von Modellen mit unterschiedlicher Anzahl von Variablen auszuwählen. Diese beinhalten:
Dabei ist \(d\) die Anzahl der Prädiktoren und \(\sigma^2\) eine Schätzung der Varianz des Fehlers (\(\epsilon\))) mit jeder Antwortmessung in einem Regressionsmodell verbunden. Jede dieser Statistiken fügt dem Trainings-\(RSS\) eine Strafe hinzu, um die Tatsache auszugleichen, dass der Trainingsfehler dazu neigt, den Testfehler zu unterschätzen. Die Strafe steigt eindeutig mit zunehmender Anzahl von Prädiktoren im Modell.
Daher liefern diese Statistiken eine unvoreingenommene Schätzung der Test-MSE. Wenn wir unser Modell unter Verwendung eines Trainings- / Testvalidierungsansatzes durchführen, können wir diese Statistiken verwenden, um das bevorzugte Modell zu bestimmen. Diese Statistiken sind in der Ausgabe der Funktion regsubsets enthalten.
Im Folgenden werden diese Informationen extrahiert und aufgezeichnet.
results <- summary(best_subset_WG1)
# Extrahieren und plotten der Ergebnisse
tibble(predictors = 1:37,
adj_R2 = results$adjr2,
Cp = results$cp,
BIC = results$bic) %>%
gather(statistic, value, -predictors) %>%
ggplot(aes(predictors, value, color = statistic)) +
geom_line(show.legend = F) +
geom_point(show.legend = F) +
facet_wrap(~ statistic, scales = "free")## [1] 30
## [1] 21
## [1] 27
Es ist erkennbar, dass die Ergebnisse leicht unterschiedliche Modelle identifizieren, die als die besten angesehen werden. Die ajustierte \(R^2\)-Statistik legt nahe, dass das 30-Variablen-Modell bevorzugt wird, die \(BIC\)-Statistik schlägt das 21-Variablenmodell vor und der \(C_{p}\) das 27-Variablen-Modell vor.
Die Variablen und Koeffizienten, die diese Modelle enthalten, können mittels der coef-Funktion verglichen werden:
## (Intercept) KielerWoche Wochentag_cDonnerstag
## 108.888732 14.620447 19.776807
## Wochentag_cFreitag Wochentag_cMontag Wochentag_cSamstag
## 12.122001 15.949012 26.166057
## Wochentag_cSonntag Monat_cFebruar Monat_cJanuar
## -40.029008 -13.269996 -14.219094
## Monat_cOktober Monat_cSeptember SommerferienSH
## 17.164916 8.799025 14.631170
## SommerferienNRW SommerferienNDS Feiertag
## 11.960519 8.995801 122.763316
## Ostern ChristiHimmelfahrt Pfingsten
## -319.204961 -184.568855 -167.813622
## TDE Ostern_ext Pfingsten_ext
## -187.373875 173.702911 29.101572
## JahreszeitHerbst
## -12.768112
Die 21 Variablen die in das Modell mit einbezogen werden würden, sind die folgenden:
- KielerWoche
- Wochentag_cDonnerstag
- Wochentag_cFreitag
- Wochentag_cMontag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cFebruar
- Monat_cJanuar
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- Pfingsten_ext
- JahreszeitHerbst
## (Intercept) KielerWoche Wochentag_cDonnerstag
## 109.979243 22.711772 19.764702
## Wochentag_cFreitag Wochentag_cMontag Wochentag_cSamstag
## 11.864151 16.294480 25.966181
## Wochentag_cSonntag Monat_cDezember Monat_cFebruar
## -39.964915 14.067631 -14.356062
## Monat_cJanuar Monat_cMärz Monat_cNovember
## -15.298812 -5.608354 13.570493
## Monat_cOktober Monat_cSeptember SommerferienSH
## 30.889733 22.187302 16.448257
## SommerferienNRW SommerferienNDS SommerferienHE
## 18.744751 13.725594 6.280986
## Feiertag Ostern ChristiHimmelfahrt
## 107.654470 -303.677882 -184.488650
## Pfingsten TDE Ostern_ext
## -153.009495 -172.330009 173.858839
## ChristiHimmelfahrt_ext Pfingsten_ext JahreszeitHerbst
## 13.950236 28.111000 -27.566990
## JahreszeitSommer
## -15.008407
Das 27-Variablen-Modell gemäß best subset selection liefert folgendes Ergebnis:
- KielerWoche
- Wochentag_cDonnerstag
- Wochentag_cFreitag
- Wochentag_cMontag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cDezember
- Monat_cFebruar
- Monat_cJanuar
- Monat_cMärz
- Monat_cNovember
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- JahreszeitHerbst
- JahreszeitSommer
## (Intercept) KielerWoche Bewoelkung
## 119.1231442 23.7174805 -0.5196306
## Temperatur Wochentag_cDonnerstag Wochentag_cFreitag
## -0.3759704 18.1655872 10.2453131
## Wochentag_cMittwoch Wochentag_cMontag Wochentag_cSamstag
## -3.3108524 14.6494272 24.3158335
## Wochentag_cSonntag Monat_cDezember Monat_cFebruar
## -41.7063193 11.7515546 -17.3664609
## Monat_cJanuar Monat_cMärz Monat_cNovember
## -18.8572469 -7.6827953 11.3302774
## Monat_cOktober Monat_cSeptember SommerferienSH
## 30.3151309 22.2488212 16.4660783
## SommerferienNRW SommerferienNDS SommerferienHE
## 19.1102941 14.2821906 6.4686540
## Feiertag Ostern ChristiHimmelfahrt
## 108.0200659 -303.2993112 -185.8569373
## Pfingsten TDE Ostern_ext
## -153.4921447 -172.6591571 171.9813148
## ChristiHimmelfahrt_ext Pfingsten_ext JahreszeitHerbst
## 14.6316521 28.3177633 -27.2478868
## JahreszeitSommer
## -13.5296506
Das 30-Variablen-Modell gemäß best subset selection liefert folgendes Ergebnis:
- KielerWoche
- Bewoelkung
- Temperatur
- Wochentag_cDonnerstag
- Wochentag_cFreitag
- Wochentag_cMittwoch
- Wochentag_cMontag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cDezember
- Monat_cFebruar
- Monat_cJanuar
- Monat_cMärz
- Monat_cNovember
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- JahreszeitHerbst
- JahreszeitSommer
Der gleiche Prozess kann durch schrittweise Vorwärts- und Rückwärtsauswahl durchgeführt werden, um noch mehr Optionen für optimale Modelle zu erhalten:
forward <- regsubsets(Umsatz ~ ., df_lm_train_WG1, nvmax = 37, method = "forward")
backward <- regsubsets(Umsatz ~ ., df_lm_train_WG1, nvmax = 37, method = "backward")
# Welches Modell minimiert den Cp?
which.min(summary(forward)$cp)## [1] 31
## [1] 27
Wenn man das optimale \(C_{p}\) für vorwärts und rückwärts schrittweise bewertet, ist erkennbar, dass gemäß der Vorwärts-Methode ein 31-Variablen-Modell die \(C_{p}\)-Statistik minimiert. Die Rückwärtsmethode schlägt ein 27-Variablen-Modell vor, ähnlich dem oben beschriebenen besten Teilmengenansatz.
Ein Vergleich des 27-Variablen-backward-Modell mit dem 27-Variablen-Modell der “best subset selection” ergibt Folgendes:
## (Intercept) KielerWoche Wochentag_cDonnerstag
## 109.979243 22.711772 19.764702
## Wochentag_cFreitag Wochentag_cMontag Wochentag_cSamstag
## 11.864151 16.294480 25.966181
## Wochentag_cSonntag Monat_cDezember Monat_cFebruar
## -39.964915 14.067631 -14.356062
## Monat_cJanuar Monat_cMärz Monat_cNovember
## -15.298812 -5.608354 13.570493
## Monat_cOktober Monat_cSeptember SommerferienSH
## 30.889733 22.187302 16.448257
## SommerferienNRW SommerferienNDS SommerferienHE
## 18.744751 13.725594 6.280986
## Feiertag Ostern ChristiHimmelfahrt
## 107.654470 -303.677883 -184.488651
## Pfingsten TDE Ostern_ext
## -153.009495 -172.330010 173.858839
## ChristiHimmelfahrt_ext Pfingsten_ext JahreszeitHerbst
## 13.950236 28.111000 -27.566990
## JahreszeitSommer
## -15.008407
- KielerWoche
- Wochentag_cDonnerstag
- Wochentag_cFreitag
- Wochentag_cMontag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cDezember
- Monat_cFebruar
- Monat_cJanuar
- Monat_cMärz
- Monat_cNovember
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- JahreszeitHerbst
- JahreszeitSommer
Beide Verfahren schlagen dieselben Variablen für die Aufnahme in ein Regressionsmodell vor.
Betrachtet man das 31-Variablen-Modell der forward stepwise-Methode, ergibt sich folgendes Bild:
## (Intercept) KielerWoche Bewoelkung
## 119.0668487 23.5756179 -0.5189617
## Temperatur Wochentag_cDonnerstag Wochentag_cFreitag
## -0.3725949 18.1705826 10.1776518
## Wochentag_cMittwoch Wochentag_cMontag Wochentag_cSamstag
## -3.3729094 14.6368248 24.2473833
## Wochentag_cSonntag Monat_cDezember Monat_cFebruar
## -41.7169418 10.9075926 -17.2961926
## Monat_cJanuar Monat_cMärz Monat_cNovember
## -18.7815063 -7.6260992 10.6279017
## Monat_cOktober Monat_cSeptember SommerferienSH
## 29.5982162 21.8531767 16.3919653
## SommerferienNRW SommerferienNDS SommerferienHE
## 18.9505653 14.1327347 6.4708933
## Feiertag Ostern ChristiHimmelfahrt
## 99.0655548 -294.3801175 -176.9522735
## Pfingsten TDE Ostern_ext
## -144.5580625 -163.7168792 172.0344487
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 14.6799365 28.3557205 9.8577891
## JahreszeitHerbst JahreszeitSommer
## -26.4870412 -13.2352199
- KielerWoche
- Bewoelkung
- Temperatu*
- Wochentag_cDonnerstag
- Wochentag_cFreitag
- Wochentag_cMittwoch
- Wochentag_cMontag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cDezember
- Monat_cFebruar
- Monat_cJanuar
- Monat_cMärz
- Monat_cNovember
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- Silvester_ext
- JahreszeitHerbst
- JahreszeitSommer
Vergleicht man die Koeffizienten wiederum mit 30-Variablen-Modell der best subset selection, stimmen all Variablen überein; beim 31-Variablen-Modell wird weiterhin die Variable Silvester_ext einbezogen.
Direkte Schätzung des Testfehlers
Nun wird der Fehler der Testdaten für das beste Modell jeder Modellgröße berechnet. Zuerst wird eine Modellmatrix aus den Testdaten erstellt. Die Funktion model.matrix wird in vielen Regressionspaketen zum Erstellen einer X-Matrix aus Daten verwendet.
Jetzt kann jede Modellgröße (d.h. 1 Variable, 2 Variablen,…, 20 Variablen) durchlaufen werden und die Koeffizienten für das beste Modell dieser Größe extrahiert werden. Diese Werte werden sodann in die entsprechenden Spalten der Testmodellmatrix multipliziert, um die Vorhersagen zu bilden. Dann werden die Test-MSE berechnet.
# Erstellen eines leeren Vektors, um diesen nachfolgend mit den Fehlerwerten zu füllen
validation_errors <- vector("double", length = 37)
for(i in 1:37) {
coef_x <- coef(best_subset_WG1, id = i) # extract coefficients for model size i
pred_x <- test_m[ , names(coef_x)] %*% coef_x # predict salary using matrix algebra
validation_errors[i] <- mean((df_lm_test_WG1$Umsatz - pred_x)^2) # compute test error btwn actual & predicted salary
}
as.matrix(validation_errors)## [,1]
## [1,] 1860.918
## [2,] 1682.378
## [3,] 1497.774
## [4,] 1307.769
## [5,] 1259.792
## [6,] 1249.266
## [7,] 1206.777
## [8,] 1162.289
## [9,] 1149.677
## [10,] 1142.388
## [11,] 1124.089
## [12,] 1110.791
## [13,] 1070.296
## [14,] 1069.631
## [15,] 1062.172
## [16,] 1079.990
## [17,] 1072.604
## [18,] 1087.550
## [19,] 1079.241
## [20,] 1053.798
## [21,] 1049.652
## [22,] 1095.586
## [23,] 1089.673
## [24,] 1094.242
## [25,] 1070.017
## [26,] 1083.261
## [27,] 1080.720
## [28,] 1088.128
## [29,] 1082.239
## [30,] 1078.903
## [31,] 1073.617
## [32,] 1075.004
## [33,] 1074.223
## [34,] 1076.248
## [35,] 1076.519
## [36,] 1075.426
## [37,] 1071.687
#############################
# Alternative nach http://www.science.smith.edu/~jcrouser/SDS293/labs/lab9-r.html
val_errors = rep(NA,37)
# Iterationen über jede Größe i
for(i in 1:37){
# Extrahieren des Vektors der Prädiktoren im Best-Fit-Modell für i-Prädiktoren
coefi = coef(best_subset_WG1, id = i)
# Vorhersagen unter Verwendung der Matrixmultiplikation der Testmatrix und des Koeffizientenvektors erstellen
pred = test_m[,names(coefi)]%*%coefi
# Berechnung des MSE
val_errors[i] = mean((df_lm_test_WG1$Umsatz-pred)^2)
}
# Auffinden des Modells mit dem kleinsten Fehler
min = which.min(val_errors)
# Plotten des Fehlers für jede Modellgröße
plot(val_errors, type = 'b')
points(min, val_errors[min][1], col = "red", cex = 2, pch = 20)Es ist erkennbar, dass ein 21-Variablen-Modell, das durch den besten Teilmengenansatz erzeugt wird, den niedrigsten Test-MSE erzeugt.
Einzelne Modelle werden im Folgenden miteinander verglichen. Da sowohl die best subset selection als auch die backward selction u. a. zu einem 27-Variablen-Modell geführt haben, wird dieses getestet. Weiterhin wird das “größte” Modell mit 31 Variablen in den Vergleich einbezogen. Abschließend wird geprüft, wie ein schlankeres Modell mit 21 Variablen performt.
Teilmengenauswahl für das 27-Variablen-Modell gemäß best subset selection und backward selection
Die 27 Variablen gemäß best subset selection sind die folgenden:
- KielerWoche
- Wochentag_cDonnerstag
- Wochentag_cFreitag
- Wochentag_cMontag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cDezember
- Monat_cFebruar
- Monat_cJanuar
- Monat_cMärz
- Monat_cNovember
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- JahreszeitHerbst
- JahreszeitSommer
Die Variablen Wochentag_c, Monat_c und Jahreszeit müssen nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG1_27 <- df_lm_train_WG1 %>%
mutate(Montag=as.integer(df_lm_train_WG1$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG1$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG1$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG1$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG1$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG1$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG1$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG1$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG1$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG1$Monat_c=="Maerz")) %>%
mutate(April=as.integer(df_lm_train_WG1$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG1$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG1$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG1$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG1$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG1$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG1$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG1$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG1$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG1$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG1$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG1$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG1$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG1_27 <- df_lm_test_WG1 %>%
mutate(Montag=as.integer(df_lm_test_WG1$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG1$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG1$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG1$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG1$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG1$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG1$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG1$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG1$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG1$Monat_c=="Maerz")) %>%
mutate(April=as.integer(df_lm_test_WG1$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG1$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG1$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG1$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG1$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG1$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG1$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG1$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG1$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG1$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG1$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG1$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG1$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 27-Variablenmodell der best subset selection wird nun ein Regressionsmodell erstellt:
lm_WG1_27_train <- lm(Umsatz ~ KielerWoche + Donnerstag + Freitag + Montag + Samstag + Sonntag + Dezember + Februar
+ Januar + Maerz + November + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienNDS + SommerferienHE + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + Ostern_ext + ChristiHimmelfahrt_ext + Pfingsten_ext + Herbst + Sommer, data = df_lm_train_WG1_27)
library(broom)
glance(lm_WG1_27_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.577 0.567 25.3 54.3 5.40e-173 27 -4919. 9894.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
## Warning in predict.lm(lm_WG1_27_train, newdata = df_lm_test_WG1_27):
## prediction from a rank-deficient fit may be misleading
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 32.6708972 0.5834043 24.8277040
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt und sodann eine gemeinsame Übersichtstabelle für die Gütekennzahlen angelegt lm_vgl_kennz, die nach und nach angereichert wird mit den Ergebnissen der anderen Modelle je Warengruppe:
# Hinzufügen der Ergebnisse
df_lm_test_WG1_27 <- df_lm_test_WG1_27 %>%
mutate(predicted = lm_WG1_27_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG1_27 <- df_lm_test_WG1_27 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG1_27 <-df_lm_test_WG1_27 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG1_27 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best27_WG1")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- temp
lm_vgl_kennz %>%
arrange(WAPE)## # A tibble: 1 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7 24.7
## # ... with 1 more variable: Modell <chr>
Teilmengenauswahl für das 31-Variablen-Modell gemäß backward stepwise
Es erfolgt ein weiterer Vergleich mit dem 31 Variablen-Modell der best subset selection:
Die 31 Variablen gemäß best subset selection sind die folgenden:
- KielerWoche
- Bewoelkung
- Temperatu*
- Wochentag_cDonnerstag
- Wochentag_cFreitag
- Wochentag_cMittwoch
- Wochentag_cMontag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cDezember
- Monat_cFebruar
- Monat_cJanuar
- Monat_cMärz
- Monat_cNovember
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- Silvester_ext
- JahreszeitHerbst
- JahreszeitSommer
Die Variablen Wochentag_c, Monat_c und Jahreszeit müssen nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG1_31 <- df_lm_train_WG1 %>%
mutate(Montag=as.integer(df_lm_train_WG1$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG1$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG1$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG1$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG1$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG1$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG1$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG1$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG1$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG1$Monat_c=="Maerz")) %>%
mutate(April=as.integer(df_lm_train_WG1$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG1$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG1$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG1$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG1$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG1$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG1$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG1$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG1$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG1$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG1$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG1$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG1$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG1_31 <- df_lm_test_WG1 %>%
mutate(Montag=as.integer(df_lm_test_WG1$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG1$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG1$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG1$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG1$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG1$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG1$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG1$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG1$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG1$Monat_c=="Maerz")) %>%
mutate(April=as.integer(df_lm_test_WG1$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG1$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG1$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG1$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG1$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG1$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG1$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG1$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG1$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG1$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG1$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG1$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG1$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 31-Variablenmodell der best subset selection wird nun ein Regressionsmodell erstellt:
lm_WG1_31_train <- lm(Umsatz ~ KielerWoche + Bewoelkung + Temperatur + Donnerstag + Freitag + Mittwoch + Montag + Samstag + Sonntag + Dezember + Februar + Januar + Maerz + November + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienNDS + SommerferienHE + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + Ostern_ext + ChristiHimmelfahrt_ext + Pfingsten_ext + Silvester_ext + Herbst + Sommer, data = df_lm_train_WG1_31)
library(broom)
glance(lm_WG1_31_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.579 0.567 25.3 47.2 2.38e-170 31 -4917. 9898.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
## Warning in predict.lm(lm_WG1_31_train, newdata = df_lm_test_WG1_31):
## prediction from a rank-deficient fit may be misleading
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 32.6212367 0.5816673 24.8093885
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt und sodann eine gemeinsame Übersichtstabelle für die Gütekennzahlen angelegt lm_vgl_kennz, die nach und nach angereichert wird mit den Ergebnissen der anderen Modelle je Warengruppe:
# Hinzufügen der Ergebnisse
df_lm_test_WG1_31 <- df_lm_test_WG1_31 %>%
mutate(predicted = lm_WG1_31_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG1_31 <- df_lm_test_WG1_31 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG1_31 <-df_lm_test_WG1_31 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG1_31 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best31_WG1")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz %>%
arrange(desc(WAPE))## # A tibble: 2 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7 24.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6 24.7
## # ... with 1 more variable: Modell <chr>
Teilmengenauswahl für das 21-Variablen-Modell gemäß backward stepwise
Es erfolgt ein weiterer Vergleich mit dem 21 Variablen-Modell der best subset selection:
Die 21 Variablen gemäß best subset selection sind die folgenden:
- KielerWoche
- Wochentag_cDonnerstag
- Wochentag_cFreitag
- Wochentag_cMontag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cFebruar
- Monat_cJanuar
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- Pfingsten_ext
- JahreszeitHerbst
Die Variablen Wochentag_c, Monat_c und Jahreszeit müssen nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG1_21 <- df_lm_train_WG1 %>%
mutate(Montag=as.integer(df_lm_train_WG1$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG1$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG1$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG1$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG1$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG1$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG1$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG1$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG1$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG1$Monat_c=="Maerz")) %>%
mutate(April=as.integer(df_lm_train_WG1$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG1$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG1$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG1$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG1$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG1$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG1$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG1$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG1$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG1$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG1$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG1$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG1$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG1_21 <- df_lm_test_WG1 %>%
mutate(Montag=as.integer(df_lm_test_WG1$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG1$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG1$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG1$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG1$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG1$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG1$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG1$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG1$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG1$Monat_c=="Maerz")) %>%
mutate(April=as.integer(df_lm_test_WG1$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG1$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG1$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG1$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG1$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG1$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG1$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG1$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG1$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG1$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG1$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG1$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG1$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 21-Variablenmodell der best subset selection wird nun ein Regressionsmodell erstellt:
lm_WG1_21_train <- lm(Umsatz ~ KielerWoche + Donnerstag + Freitag + Montag + Samstag + Sonntag + Februar + Januar + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienNDS + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + Ostern_ext + Pfingsten_ext + Herbst, data = df_lm_train_WG1_21)
glance(lm_WG1_21_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.567 0.559 25.5 64.9 2.44e-172 22 -4931. 9908.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 32.3983349 0.5953173 24.7343684
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt und sodann eine gemeinsame Übersichtstabelle für die Gütekennzahlen angelegt lm_vgl_kennz, die nach und nach angereichert wird mit den Ergebnissen der anderen Modelle je Warengruppe:
# Hinzufügen der Ergebnisse
df_lm_test_WG1_21 <- df_lm_test_WG1_21 %>%
mutate(predicted = lm_WG1_21_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG1_21 <- df_lm_test_WG1_21 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG1_21 <-df_lm_test_WG1_21 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG1_21 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best21_WG1")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz %>%
arrange(WAPE)## # A tibble: 3 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4 24.5
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6 24.7
## 3 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7 24.7
## # ... with 1 more variable: Modell <chr>
Der Vergleich der Modelle zeigt, dass es keine großen Unterschiede bei den Gütekennzahlen gibt. Die 10 Variablen mehr, die im 31-Variablen-Modell gegenüber dem 21-Variablen-Modell hinzugefügt werden, scheinen keinen wirklich relevanten weiteren Prognosebeitrag zu liefern. Das schlanke Modell performt sogar am besten, wenn auch nur marginal. Da generell schlankere Modelle bevorzugt werden sollten, würde die Wahl hier auf das 21-Variablen-Modell fallen.
Für das 21-Variablen-Modell wird nun noch geprüft, ob das Hinzufügen von Interaktionseffekten eine Verbesserung bewirkt. Es könnte ja bspw. sein, dassdie Stärke des Einflusses der Kieler Woche am Wochenende anders ist als an den Wochentagen. Am Samstag und Sonntag, so könnte man argumentieren, besuchen mehr Gäste von außerhalb, also Menschen, die nicht in Kiel wohnen, die Kieler Woche, da sie nicht arbeiten müssen, mehr Zeit haben etc.
Um R dazu zu bringen, die Regressionsgerade frei variieren zu lassen, werden die Interaktionen als zusätzliche Terme zur Regressionsgeraden hinzugefügt:
lm_WG1_21_train_inter <- lm(Umsatz ~ KielerWoche + Donnerstag + Freitag + Montag + Samstag + Sonntag + Februar + Januar + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienNDS + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + Ostern_ext + Pfingsten_ext + Herbst + KielerWoche:Samstag + KielerWoche:Sonntag, data = df_lm_train_WG1_21)
glance(lm_WG1_21_train_inter)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.570 0.560 25.5 59.7 9.72e-172 24 -4928. 9907.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
## # A tibble: 24 x 5
## term estimate std.error statistic p.value
## <chr> <dbl> <dbl> <dbl> <dbl>
## 1 (Intercept) 109. 1.80 60.6 0.
## 2 KielerWoche 14.4 6.73 2.13 3.32e- 2
## 3 Donnerstag 19.8 2.56 7.74 2.37e-14
## 4 Freitag 12.1 2.54 4.77 2.13e- 6
## 5 Montag 16.0 2.57 6.20 7.90e-10
## 6 Samstag 25.4 2.57 9.89 4.20e-22
## 7 Sonntag -39.3 2.59 -15.2 4.08e-47
## 8 Februar -13.3 3.07 -4.32 1.71e- 5
## 9 Januar -14.2 3.00 -4.73 2.52e- 6
## 10 Oktober 17.2 3.42 5.01 6.40e- 7
## # ... with 14 more rows
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 32.3989306 0.5949194 24.7391370
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt und sodann eine gemeinsame Übersichtstabelle für die Gütekennzahlen angelegt lm_vgl_kennz, die nach und nach angereichert wird mit den Ergebnissen der anderen Modelle je Warengruppe:
# Hinzufügen der Ergebnisse
df_lm_test_WG1_21 <- df_lm_test_WG1_21 %>%
mutate(predicted_inter = lm_WG1_21_predict_inter)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG1_21 <- df_lm_test_WG1_21 %>%
mutate(Prognose_zuhoch = (predicted_inter >= Umsatz)) %>%
mutate(Abweichung = predicted_inter - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted_inter - Umsatz)) %>%
mutate(Abweichung_rel = (predicted_inter - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG1_21 <-df_lm_test_WG1_21 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG1_21 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best21_inter_WG1")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz %>%
arrange(WAPE)## # A tibble: 4 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4 24.5
## 2 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4 24.5
## 3 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6 24.7
## 4 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7 24.7
## # ... with 1 more variable: Modell <chr>
lm_WG1_21_train_inter <- lm(Umsatz ~ KielerWoche + Donnerstag + Freitag + Montag + Samstag + Sonntag + Februar + Januar + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienNDS + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + Ostern_ext + Pfingsten_ext + Herbst + KielerWoche:Freitag + KielerWoche:Samstag + KielerWoche:Sonntag, data = df_lm_train_WG1_21)
glance(lm_WG1_21_train_inter)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.570 0.560 25.5 57.2 5.52e-171 25 -4928. 9908.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Das Hinzufügen des Interaktionseffekts bewirkt hier keine Verbesserung. Somit bleibt es dabei, dass das 21-Variablen-Modell für Warengruppe 1 am besten performt.
Folgende Variablen sind also am besten geeignet, um Prognosen für die Umsätze in der Warengruppe 1 zu erstellen:
- KielerWoche
- Wochentage:
- Donnerstag
- Freitag
- Montag
- Samstag
- Sonntag
- Donnerstag
- Monate:
- Februar
- Januar
- Oktober
- September
- Februar
- Sommerferien:
- SH
- NRW
- NDS
- SH
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- Pfingsten_ext
- Jahreszeit:
- Herbst
6.3.2 Warengruppe 2
Erstellung von Trainings- und Testdatensätzen für Warengruppe 2
df_lm_train_WG2 <- df_lm_train %>% filter(Warengruppe == "2")
df_lm_train_WG2 <- na.omit(df_lm_train_WG2)
df_lm_train_WG2 <- df_lm_train_WG2 %>% dplyr::select(-Warengruppe)
df_lm_test_WG2 <- df_lm_test %>% filter(Warengruppe == "2")
df_lm_test_WG2 <- na.omit(df_lm_test_WG2)
df_lm_test_WG2 <- df_lm_test_WG2 %>% dplyr::select(-Warengruppe)Auswahl der am besten geeigneten Variablen Was die Vorgehensweise und die enstsprechenden Erläuterungen anbelangt, siehe 6.3.1.
Beste Teilmengenauswahl (“Best subset selection”)
Die regsubsets-Funktion gibt ein Listenobjekt mit vielen Informationen zurück. Zunächst kann der Befehl summary verwendet, um den besten Satz von Variablen für jede Modellgröße zu ermitteln.
## Subset selection object
## Call: regsubsets.formula(Umsatz ~ ., df_lm_train_WG2, nvmax = 37)
## 37 Variables (and intercept)
## Forced in Forced out
## KielerWoche FALSE FALSE
## Bewoelkung FALSE FALSE
## Temperatur FALSE FALSE
## Windgeschwindigkeit FALSE FALSE
## Wochentag_cDonnerstag FALSE FALSE
## Wochentag_cFreitag FALSE FALSE
## Wochentag_cMittwoch FALSE FALSE
## Wochentag_cMontag FALSE FALSE
## Wochentag_cSamstag FALSE FALSE
## Wochentag_cSonntag FALSE FALSE
## Monat_cAugust FALSE FALSE
## Monat_cDezember FALSE FALSE
## Monat_cFebruar FALSE FALSE
## Monat_cJanuar FALSE FALSE
## Monat_cJuli FALSE FALSE
## Monat_cJuni FALSE FALSE
## Monat_cMai FALSE FALSE
## Monat_cMärz FALSE FALSE
## Monat_cNovember FALSE FALSE
## Monat_cOktober FALSE FALSE
## Monat_cSeptember FALSE FALSE
## SommerferienSH FALSE FALSE
## SommerferienNRW FALSE FALSE
## SommerferienNDS FALSE FALSE
## SommerferienHE FALSE FALSE
## Feiertag FALSE FALSE
## Ostern FALSE FALSE
## ChristiHimmelfahrt FALSE FALSE
## Pfingsten FALSE FALSE
## TDE FALSE FALSE
## Ostern_ext FALSE FALSE
## ChristiHimmelfahrt_ext FALSE FALSE
## Pfingsten_ext FALSE FALSE
## Silvester_ext FALSE FALSE
## JahreszeitHerbst FALSE FALSE
## JahreszeitSommer FALSE FALSE
## JahreszeitWinter FALSE FALSE
## 1 subsets of each size up to 37
## Selection Algorithm: exhaustive
## KielerWoche Bewoelkung Temperatur Windgeschwindigkeit
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " "*" " "
## 5 ( 1 ) " " " " "*" " "
## 6 ( 1 ) " " " " "*" " "
## 7 ( 1 ) " " " " "*" " "
## 8 ( 1 ) "*" " " "*" " "
## 9 ( 1 ) "*" " " "*" " "
## 10 ( 1 ) "*" " " "*" " "
## 11 ( 1 ) "*" " " "*" " "
## 12 ( 1 ) "*" " " "*" " "
## 13 ( 1 ) "*" " " "*" " "
## 14 ( 1 ) "*" " " "*" " "
## 15 ( 1 ) "*" " " "*" " "
## 16 ( 1 ) "*" " " "*" " "
## 17 ( 1 ) "*" " " "*" " "
## 18 ( 1 ) "*" " " "*" " "
## 19 ( 1 ) "*" " " "*" " "
## 20 ( 1 ) "*" " " "*" " "
## 21 ( 1 ) "*" " " "*" " "
## 22 ( 1 ) "*" " " "*" " "
## 23 ( 1 ) "*" " " "*" "*"
## 24 ( 1 ) "*" " " "*" "*"
## 25 ( 1 ) "*" "*" " " "*"
## 26 ( 1 ) "*" "*" " " "*"
## 27 ( 1 ) "*" "*" " " "*"
## 28 ( 1 ) "*" "*" " " "*"
## 29 ( 1 ) "*" "*" " " "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## Wochentag_cDonnerstag Wochentag_cFreitag Wochentag_cMittwoch
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " " "
## 9 ( 1 ) " " " " " "
## 10 ( 1 ) " " " " " "
## 11 ( 1 ) " " " " " "
## 12 ( 1 ) " " " " " "
## 13 ( 1 ) " " " " " "
## 14 ( 1 ) " " " " " "
## 15 ( 1 ) " " " " " "
## 16 ( 1 ) " " " " " "
## 17 ( 1 ) " " " " " "
## 18 ( 1 ) " " "*" " "
## 19 ( 1 ) " " "*" " "
## 20 ( 1 ) " " "*" " "
## 21 ( 1 ) " " "*" " "
## 22 ( 1 ) " " "*" " "
## 23 ( 1 ) " " "*" " "
## 24 ( 1 ) " " "*" " "
## 25 ( 1 ) " " "*" " "
## 26 ( 1 ) " " "*" "*"
## 27 ( 1 ) " " "*" "*"
## 28 ( 1 ) " " "*" "*"
## 29 ( 1 ) " " "*" "*"
## 30 ( 1 ) " " "*" "*"
## 31 ( 1 ) " " "*" "*"
## 32 ( 1 ) " " "*" "*"
## 33 ( 1 ) "*" "*" " "
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
## Wochentag_cMontag Wochentag_cSamstag Wochentag_cSonntag
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " "*"
## 3 ( 1 ) " " "*" "*"
## 4 ( 1 ) " " "*" "*"
## 5 ( 1 ) " " "*" "*"
## 6 ( 1 ) " " "*" "*"
## 7 ( 1 ) " " "*" "*"
## 8 ( 1 ) " " "*" "*"
## 9 ( 1 ) " " "*" "*"
## 10 ( 1 ) " " "*" "*"
## 11 ( 1 ) " " "*" "*"
## 12 ( 1 ) " " "*" "*"
## 13 ( 1 ) " " "*" "*"
## 14 ( 1 ) " " "*" "*"
## 15 ( 1 ) " " "*" "*"
## 16 ( 1 ) " " "*" "*"
## 17 ( 1 ) " " "*" "*"
## 18 ( 1 ) " " "*" "*"
## 19 ( 1 ) " " "*" "*"
## 20 ( 1 ) " " "*" "*"
## 21 ( 1 ) " " "*" "*"
## 22 ( 1 ) " " "*" "*"
## 23 ( 1 ) " " "*" "*"
## 24 ( 1 ) " " "*" "*"
## 25 ( 1 ) " " "*" "*"
## 26 ( 1 ) " " "*" "*"
## 27 ( 1 ) " " "*" "*"
## 28 ( 1 ) " " "*" "*"
## 29 ( 1 ) " " "*" "*"
## 30 ( 1 ) " " "*" "*"
## 31 ( 1 ) " " "*" "*"
## 32 ( 1 ) " " "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
## Monat_cAugust Monat_cDezember Monat_cFebruar Monat_cJanuar
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " " " " "
## 8 ( 1 ) " " " " " " " "
## 9 ( 1 ) " " " " " " " "
## 10 ( 1 ) " " " " " " " "
## 11 ( 1 ) " " " " " " " "
## 12 ( 1 ) " " " " " " " "
## 13 ( 1 ) " " " " " " " "
## 14 ( 1 ) " " " " " " " "
## 15 ( 1 ) " " " " " " " "
## 16 ( 1 ) " " " " " " " "
## 17 ( 1 ) " " " " " " " "
## 18 ( 1 ) " " " " " " " "
## 19 ( 1 ) " " " " " " "*"
## 20 ( 1 ) " " " " "*" "*"
## 21 ( 1 ) "*" " " " " " "
## 22 ( 1 ) "*" "*" " " " "
## 23 ( 1 ) "*" "*" " " " "
## 24 ( 1 ) "*" "*" " " " "
## 25 ( 1 ) "*" "*" " " " "
## 26 ( 1 ) "*" "*" " " " "
## 27 ( 1 ) "*" "*" " " " "
## 28 ( 1 ) "*" "*" "*" " "
## 29 ( 1 ) "*" "*" "*" " "
## 30 ( 1 ) "*" "*" "*" " "
## 31 ( 1 ) "*" "*" "*" " "
## 32 ( 1 ) "*" "*" "*" " "
## 33 ( 1 ) "*" "*" "*" " "
## 34 ( 1 ) "*" "*" "*" " "
## 35 ( 1 ) "*" "*" " " "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## Monat_cJuli Monat_cJuni Monat_cMai Monat_cMärz Monat_cNovember
## 1 ( 1 ) " " " " " " " " " "
## 2 ( 1 ) " " " " " " " " " "
## 3 ( 1 ) " " " " " " " " " "
## 4 ( 1 ) " " " " " " " " " "
## 5 ( 1 ) " " " " " " " " " "
## 6 ( 1 ) " " " " " " " " " "
## 7 ( 1 ) " " " " " " " " " "
## 8 ( 1 ) " " " " " " " " " "
## 9 ( 1 ) " " " " " " " " "*"
## 10 ( 1 ) " " " " " " " " " "
## 11 ( 1 ) " " " " " " " " " "
## 12 ( 1 ) " " " " " " " " " "
## 13 ( 1 ) " " " " " " " " " "
## 14 ( 1 ) " " " " " " " " " "
## 15 ( 1 ) " " " " " " " " " "
## 16 ( 1 ) " " " " " " " " " "
## 17 ( 1 ) " " " " " " "*" " "
## 18 ( 1 ) " " " " " " "*" " "
## 19 ( 1 ) " " " " " " "*" " "
## 20 ( 1 ) " " " " " " "*" " "
## 21 ( 1 ) "*" "*" "*" " " " "
## 22 ( 1 ) "*" "*" "*" " " " "
## 23 ( 1 ) "*" "*" "*" " " " "
## 24 ( 1 ) "*" "*" "*" " " "*"
## 25 ( 1 ) "*" "*" "*" " " "*"
## 26 ( 1 ) "*" "*" "*" " " "*"
## 27 ( 1 ) "*" "*" "*" " " "*"
## 28 ( 1 ) "*" "*" "*" " " "*"
## 29 ( 1 ) "*" "*" "*" " " "*"
## 30 ( 1 ) "*" "*" "*" " " "*"
## 31 ( 1 ) "*" "*" "*" " " "*"
## 32 ( 1 ) "*" "*" "*" " " "*"
## 33 ( 1 ) "*" "*" "*" " " "*"
## 34 ( 1 ) "*" "*" "*" " " "*"
## 35 ( 1 ) "*" "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*" "*"
## Monat_cOktober Monat_cSeptember SommerferienSH SommerferienNRW
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " "*"
## 5 ( 1 ) " " " " " " "*"
## 6 ( 1 ) " " " " " " "*"
## 7 ( 1 ) " " " " " " "*"
## 8 ( 1 ) " " " " " " "*"
## 9 ( 1 ) " " " " " " "*"
## 10 ( 1 ) "*" " " " " "*"
## 11 ( 1 ) "*" " " " " "*"
## 12 ( 1 ) "*" " " " " "*"
## 13 ( 1 ) "*" " " " " "*"
## 14 ( 1 ) "*" " " "*" "*"
## 15 ( 1 ) "*" " " "*" "*"
## 16 ( 1 ) "*" "*" "*" "*"
## 17 ( 1 ) "*" "*" "*" "*"
## 18 ( 1 ) "*" "*" "*" "*"
## 19 ( 1 ) "*" "*" "*" "*"
## 20 ( 1 ) "*" "*" "*" "*"
## 21 ( 1 ) "*" "*" "*" "*"
## 22 ( 1 ) "*" "*" "*" "*"
## 23 ( 1 ) "*" "*" "*" "*"
## 24 ( 1 ) "*" "*" "*" "*"
## 25 ( 1 ) "*" "*" "*" "*"
## 26 ( 1 ) "*" "*" "*" "*"
## 27 ( 1 ) "*" "*" "*" "*"
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## SommerferienNDS SommerferienHE Feiertag Ostern
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " "*" " "
## 6 ( 1 ) " " "*" "*" " "
## 7 ( 1 ) " " "*" "*" " "
## 8 ( 1 ) " " "*" "*" " "
## 9 ( 1 ) " " "*" "*" " "
## 10 ( 1 ) " " "*" "*" " "
## 11 ( 1 ) " " "*" "*" " "
## 12 ( 1 ) " " "*" " " " "
## 13 ( 1 ) " " "*" " " " "
## 14 ( 1 ) "*" "*" " " " "
## 15 ( 1 ) "*" "*" "*" " "
## 16 ( 1 ) "*" "*" "*" " "
## 17 ( 1 ) "*" "*" "*" " "
## 18 ( 1 ) "*" "*" "*" " "
## 19 ( 1 ) "*" "*" "*" " "
## 20 ( 1 ) "*" "*" "*" " "
## 21 ( 1 ) "*" "*" "*" " "
## 22 ( 1 ) "*" "*" "*" " "
## 23 ( 1 ) "*" "*" "*" " "
## 24 ( 1 ) "*" "*" "*" " "
## 25 ( 1 ) "*" "*" "*" " "
## 26 ( 1 ) "*" "*" "*" " "
## 27 ( 1 ) "*" "*" "*" "*"
## 28 ( 1 ) "*" "*" "*" " "
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" " "
## 33 ( 1 ) "*" "*" "*" " "
## 34 ( 1 ) "*" "*" "*" " "
## 35 ( 1 ) "*" "*" "*" " "
## 36 ( 1 ) "*" "*" "*" " "
## 37 ( 1 ) "*" "*" "*" "*"
## ChristiHimmelfahrt Pfingsten TDE Ostern_ext
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " " " "*"
## 8 ( 1 ) " " " " " " "*"
## 9 ( 1 ) " " " " " " "*"
## 10 ( 1 ) " " " " " " "*"
## 11 ( 1 ) " " " " " " "*"
## 12 ( 1 ) " " "*" " " "*"
## 13 ( 1 ) " " "*" " " "*"
## 14 ( 1 ) " " "*" " " "*"
## 15 ( 1 ) " " " " " " "*"
## 16 ( 1 ) " " " " " " "*"
## 17 ( 1 ) " " " " " " "*"
## 18 ( 1 ) " " " " " " "*"
## 19 ( 1 ) " " " " " " "*"
## 20 ( 1 ) " " " " " " "*"
## 21 ( 1 ) " " " " " " "*"
## 22 ( 1 ) " " " " " " "*"
## 23 ( 1 ) " " " " " " "*"
## 24 ( 1 ) " " " " " " "*"
## 25 ( 1 ) " " " " " " "*"
## 26 ( 1 ) " " " " " " "*"
## 27 ( 1 ) " " " " " " "*"
## 28 ( 1 ) " " " " " " "*"
## 29 ( 1 ) " " " " " " "*"
## 30 ( 1 ) " " " " " " "*"
## 31 ( 1 ) " " "*" " " "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " " "
## 9 ( 1 ) " " " " " "
## 10 ( 1 ) " " " " " "
## 11 ( 1 ) " " " " "*"
## 12 ( 1 ) "*" " " "*"
## 13 ( 1 ) "*" " " "*"
## 14 ( 1 ) "*" " " "*"
## 15 ( 1 ) "*" "*" "*"
## 16 ( 1 ) "*" "*" "*"
## 17 ( 1 ) "*" "*" "*"
## 18 ( 1 ) "*" "*" "*"
## 19 ( 1 ) "*" "*" "*"
## 20 ( 1 ) "*" "*" "*"
## 21 ( 1 ) "*" "*" "*"
## 22 ( 1 ) "*" "*" "*"
## 23 ( 1 ) "*" "*" "*"
## 24 ( 1 ) "*" "*" "*"
## 25 ( 1 ) "*" "*" "*"
## 26 ( 1 ) "*" "*" "*"
## 27 ( 1 ) "*" "*" "*"
## 28 ( 1 ) "*" "*" "*"
## 29 ( 1 ) "*" "*" "*"
## 30 ( 1 ) "*" "*" "*"
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
## JahreszeitHerbst JahreszeitSommer JahreszeitWinter
## 1 ( 1 ) " " "*" " "
## 2 ( 1 ) " " "*" " "
## 3 ( 1 ) " " "*" " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " " "
## 9 ( 1 ) " " " " " "
## 10 ( 1 ) "*" " " " "
## 11 ( 1 ) "*" " " " "
## 12 ( 1 ) "*" " " " "
## 13 ( 1 ) "*" "*" " "
## 14 ( 1 ) "*" " " " "
## 15 ( 1 ) "*" " " " "
## 16 ( 1 ) "*" " " " "
## 17 ( 1 ) "*" " " " "
## 18 ( 1 ) "*" " " " "
## 19 ( 1 ) "*" " " " "
## 20 ( 1 ) "*" " " " "
## 21 ( 1 ) "*" " " " "
## 22 ( 1 ) "*" " " " "
## 23 ( 1 ) "*" " " " "
## 24 ( 1 ) "*" " " " "
## 25 ( 1 ) "*" " " "*"
## 26 ( 1 ) "*" " " "*"
## 27 ( 1 ) "*" " " "*"
## 28 ( 1 ) "*" "*" "*"
## 29 ( 1 ) "*" "*" "*"
## 30 ( 1 ) "*" "*" "*"
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
Für ein Modell mit einer Variablen kann beobachtet werden, dass die erzeugte Dummy-Variable Sommer ein Sternchen hat, was signalisiert, dass ein Regressionsmodell mit Umsatz ~ Sommer das beste Einzelvariablenmodell ist. Das beste 2-Variablen-Modell ist Umsatz ~ Sommer + Wochentag_cSonntag. Das beste 3-Variablen-Modell ist Umsatz ~ Sommer + Wochentag_cSonntag + Wochentag_cSamstag. Das beste 4-Variablen-Modell ist interessant: Umsatz ~ Wochentag_cSonntag + Wochentag_cSamstag + SommerferienNRW + Temperatur. Die Variable Sommer taucht in diesem Modell nicht mehr auf; allerdings wird diese indirekt einbezogen, da sowohl die Tempertaur als auch die Sommerferien NRW mit dem Sommer verknüpft sind.
Schrittweise Auswahl (“Stepwise selection”)
Schrittweise vorwärts (Forward stepwise)
Die schrittweise Vorwärtsauswahl kann mit regsubsets durchgeführt werden, indem die method = "forward" gesetzt wird:
Schrittweise rückwärts (Backward stepwise)
Die schrittweise Vorwärtsauswahl kann mit regsubsets durchgeführt werden, indem die method = "backward" gesetzt wird:
Modellauswahl
Indirekte Schätzung des Testfehlers mit \(C_{p}\), \(AIC\), \(BIC\) und adjustiertem \(R^2\)
results <- summary(best_subset_WG2)
# Extrahieren und plotten der Ergebnisse
tibble(predictors = 1:37,
adj_R2 = results$adjr2,
Cp = results$cp,
BIC = results$bic) %>%
gather(statistic, value, -predictors) %>%
ggplot(aes(predictors, value, color = statistic)) +
geom_line(show.legend = F) +
geom_point(show.legend = F) +
facet_wrap(~ statistic, scales = "free")## [1] 32
## [1] 23
## [1] 29
Es ist erkennbar, dass die Ergebnisse leicht unterschiedliche Modelle identifizieren, die als die besten angesehen werden. Die ajustierte \(R^2\)-Statistik legt nahe, dass das 32-Variablen-Modell bevorzugt wird, die \(BIC\)-Statistik schlägt das 23-Variablenmodell vor und der \(C_{p}\) das 29-Variablen-Modell vor.
Der gleiche Prozess kann durch schrittweise Vorwärts- und Rückwärtsauswahl durchgeführt werden, um noch mehr Optionen für optimale Modelle zu erhalten:
forward <- regsubsets(Umsatz ~ ., df_lm_train_WG2, nvmax = 37, method = "forward")
backward <- regsubsets(Umsatz ~ ., df_lm_train_WG2, nvmax = 37, method = "backward")
# Welches Modell minimiert den Cp?
which.min(summary(forward)$cp)## [1] 31
## [1] 29
Wenn man das optimale \(C_{p}\) für vorwärts und rückwärts schrittweise bewertet, ist erkennbar, dass gemäß der Vorwärts-Methode ein 31-Variablen-Modell die \(C_{p}\)-Statistik minimiert. Die Rückwärtsmethode schlägt ein 29-Variablen-Modell vor.
Wenn wir die Koeffizienten dieser Modelle bewerten, ergibt sich bzgl. der Zusammensetzung der Prädikatoren folgendes Bild:
## (Intercept) KielerWoche Temperatur
## 255.058980 99.262851 1.539860
## Windgeschwindigkeit Wochentag_cFreitag Wochentag_cSamstag
## 1.024593 15.898462 104.370577
## Wochentag_cSonntag Monat_cAugust Monat_cDezember
## 159.502725 51.265505 18.703341
## Monat_cJuli Monat_cJuni Monat_cMai
## 61.459395 51.609523 38.326687
## Monat_cOktober Monat_cSeptember SommerferienSH
## 85.540654 57.119460 50.541531
## SommerferienNRW SommerferienNDS SommerferienHE
## 87.469236 28.601771 51.119857
## Feiertag Ostern_ext ChristiHimmelfahrt_ext
## 74.085008 227.664940 87.741193
## Pfingsten_ext Silvester_ext JahreszeitHerbst
## 65.794712 154.771010 -36.760166
Folgende Variablen werden in das 23-Variablen-Modell integriert:
- KielerWoche
- Temperatur
- Windgeschwindigkeit
- Wochentag_cFreitag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cAugust
- Monat_cDezember
- Monat_cJuli
- Monat_cJuni
- Monat_cMai
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- Silvester_ext
- JahreszeitHerbst
## (Intercept) KielerWoche Bewoelkung
## 285.1959994 110.6825404 -1.7340847
## Windgeschwindigkeit Wochentag_cFreitag Wochentag_cMittwoch
## 0.9935373 14.1250135 -8.6086174
## Wochentag_cSamstag Wochentag_cSonntag Monat_cAugust
## 101.7853127 157.2936678 79.2083263
## Monat_cDezember Monat_cFebruar Monat_cJuli
## 44.9063897 11.4307856 85.7339271
## Monat_cJuni Monat_cMai Monat_cNovember
## 61.6719636 41.6951069 38.5158005
## Monat_cOktober Monat_cSeptember SommerferienSH
## 123.7686825 88.1214251 48.4301824
## SommerferienNRW SommerferienNDS SommerferienHE
## 90.7737369 35.1848596 48.7233272
## Feiertag Ostern Ostern_ext
## 84.4931092 -54.5178447 243.8465559
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 85.8960768 57.2657853 135.3120143
## JahreszeitHerbst JahreszeitSommer JahreszeitWinter
## -75.4096447 -18.7240422 -20.5139300
Beim 29-Variablen-Modell werden folgende Variablen gegenüber dem 23-Variablen-Modell ergänzt:
- Wochentag_cMittwoch
- Monat_cFebruar
- Monat_cNovember
- Ostern
- JahreszeitSommer
- JahreszeitWinter
Weiterhin wurde die Temperatur gegen die Variable Bewoelkung “getauscht”.
## (Intercept) KielerWoche Bewoelkung
## 277.0558412 109.1795588 -1.4125293
## Temperatur Windgeschwindigkeit Wochentag_cFreitag
## 0.7115207 0.9795046 13.8471461
## Wochentag_cMittwoch Wochentag_cSamstag Wochentag_cSonntag
## -8.7469925 102.0402273 157.1575563
## Monat_cAugust Monat_cDezember Monat_cFebruar
## 70.9326129 43.7719952 11.5790448
## Monat_cJuli Monat_cJuni Monat_cMai
## 78.0819735 55.5365463 37.7302208
## Monat_cNovember Monat_cOktober Monat_cSeptember
## 36.8293615 118.5573140 80.8000391
## SommerferienSH SommerferienNRW SommerferienNDS
## 48.8069000 90.1958932 34.5184450
## SommerferienHE Feiertag ChristiHimmelfahrt
## 48.5570764 30.4854986 48.2951446
## Pfingsten TDE Ostern_ext
## 80.9105178 58.1758050 244.5138648
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 86.5497501 44.9883011 162.9135444
## JahreszeitHerbst JahreszeitSommer JahreszeitWinter
## -72.2681414 -17.3824973 -16.9097959
- KielerWoche
- Bewoelkung
- Temperatur
- Windgeschwindigkeit
- Wochentag_cFreitag
- Wochentag_cMittwoch
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cAugust
- Monat_cDezember
- Monat_cFebruar
- Monat_cJuli
- Monat_cJuni
- Monat_cMai
- Monat_cNovember
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- Silvester_ext
- JahreszeitHerbst
- JahreszeitSommer
- JahreszeitWinter
Der Unterschied zwischen Prädiktoren im 29- und 32-Variablen-Modell besteht größtenteils aus einer Erweiterung (fett marktierte Variablen). Nicht mehr dabei ist die Variable Ostern.
## (Intercept) KielerWoche Bewoelkung
## 278.8911307 105.7241313 -1.4456642
## Temperatur Windgeschwindigkeit Wochentag_cFreitag
## 0.7658329 1.0186900 13.6069261
## Wochentag_cMittwoch Wochentag_cSamstag Wochentag_cSonntag
## -9.0063870 102.2745335 156.5837730
## Monat_cAugust Monat_cDezember Monat_cFebruar
## 61.0043068 28.5646504 -7.4996625
## Monat_cJanuar Monat_cJuli Monat_cJuni
## -18.6575385 69.5644438 51.5651333
## Monat_cMai Monat_cMärz Monat_cNovember
## 34.8087325 -16.1000529 22.8978618
## Monat_cOktober Monat_cSeptember SommerferienSH
## 105.2746621 69.4633491 49.3516639
## SommerferienNRW SommerferienNDS SommerferienHE
## 89.0775459 32.5576980 49.5702330
## Feiertag Pfingsten Ostern_ext
## 60.9717893 50.7706527 229.7017974
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 90.0427705 45.2939007 143.7739953
## JahreszeitHerbst JahreszeitSommer
## -60.6462949 -10.3004626
## (Intercept) KielerWoche Bewoelkung
## 266.8760830 100.6303933 -1.4806830
## Temperatur Windgeschwindigkeit Wochentag_cDonnerstag
## 0.9248882 1.0762859 9.0862054
## Wochentag_cFreitag Wochentag_cMontag Wochentag_cSamstag
## 20.3717443 7.9979502 108.8098510
## Wochentag_cSonntag Monat_cAugust Monat_cDezember
## 163.5665803 53.1171170 28.1964327
## Monat_cJanuar Monat_cJuli Monat_cJuni
## -14.0033239 62.8094016 51.9772611
## Monat_cMai Monat_cMärz Monat_cNovember
## 37.3506429 -12.4817405 20.8335466
## Monat_cOktober Monat_cSeptember SommerferienSH
## 102.0348318 62.6385147 49.4140697
## SommerferienNRW SommerferienNDS SommerferienHE
## 88.3186268 30.0781344 50.6258543
## Feiertag Ostern_ext ChristiHimmelfahrt_ext
## 72.0622903 225.2186266 86.3047370
## Pfingsten_ext Silvester_ext JahreszeitHerbst
## 67.2084386 142.0156830 -54.7108141
Vergleicht man, das 29-Variablen-Modell der best subset selection mit dem 27-Variablen-Modell der backward selection wird erkennbar, dass die Modelle zwar viele gemeinsame Prädiktoren (24) aufnehmen, dass es jedoch auch deutliche Abweichungen bzw. Unterschiede gibt:
Während in der best subset selection ein Wochentag (Mittwoch), ein Monat (Februar), Ostern und zwei Jahreszeiten (Sommer, Winter) einbezogen werden, sollten nach der backward selection die Temperatur, zwei Wochentage (Donnerstag und Montag) sowie zwei Monate (Januar, März) in das Modell aufgenommen werden.
Ein Vergleich des best subset 32-Variablen-Modell mit dem backward selection 31-Variablen-Modell nach forward selection ergibt folgendes:
Die beiden Modelle unterscheiden sich zwar nur marginal, aber auch hier gibt es Unterschiede zwischen der best subset selection und der stepwise selection.
Diese Ergebnisse unterstreicht zwei wichtige Erkenntnisse:
- Unterschiedliche Teilmengenverfahren (beste Teilmenge vs. schrittweise vorwärts oder rückwärts schrittweise) identifizieren durchaus nicht selten unterschiedliche „beste“ Modelle.
- Unterschiedliche Statistiken zur indirekten Fehlertestschätzung (\(C_p\), \(AIC\), \(BIC\) und \(Adjusted\) \(R^2\)) indentifizieren verschiedene „beste“ Modelle.
Aus diesem Grund ist es wichtig, immer eine Validierung durchzuführen. Dies bedeutet, dass der Testfehler immer direkt geschätzt werden sollte, entweder mithilfe eines Validierungssatzes oder mithilfe einer Kreuzvalidierung.
Direkte Schätzung des Testfehlers
Nun wird der Fehler der Testdaten für das beste Modell jeder Modellgröße berechnet. Zuerst wird eine Modellmatrix aus den Testdaten erstellt. Die Funktion model.matrix wird in vielen Regressionspaketen zum Erstellen einer X-Matrix aus Daten verwendet.
Jetzt kann jede Modellgröße (d.h. 1 Variable, 2 Variablen,…, 20 Variablen) durchlaufen werden und die Koeffizienten für das beste Modell dieser Größe extrahiert werden. Diese Werte werden sodann in die entsprechenden Spalten der Testmodellmatrix multipliziert, um die Vorhersagen zu bilden. Dann werden die Test-MSE berechnet.
# Erstellen eines leeren Vektors, um diesen nachfolgend mit den Fehlerwerten zu füllen
val_errors = rep(NA, 37)
# Iterationen über jede Größe i
for(i in 1:37){
# Extrahieren des Vektors der Prädiktoren im Best-Fit-Modell für i-Prädiktoren
coefi = coef(best_subset_WG2, id = i)
# Vorhersagen unter Verwendung der Matrixmultiplikation der Testmatrix und des Koeffizientenvektors erstellen
pred = test_m[,names(coefi)]%*%coefi
# Berechnung des MSE
val_errors[i] = mean((df_lm_test_WG2$Umsatz-pred)^2)
}
# Auffinden des Modells mit dem kleinsten Fehler
min = which.min(val_errors)
# Plotten des Fehlers für jede Modellgröße
plot(val_errors, type = 'b')
points(min, val_errors[min][1], col = "red", cex = 2, pch = 20)Es ist erkennbar, dass ein 24-Variablen-Modell, das durch den besten Teilmengenansatz erzeugt wird, den niedrigsten Test-MSE erzeugt. Auch ein 30-Variablen-Modell scheinz vergleichweichsweise gut zu performen.
Wir können jetzt die beste Teilmengenauswahl für den gesamten Datensatz durchführen, um zum einen das 24-Variablen-Modell zu erhalten. Dieses Modell wird mit den 32-Variablen-Modellen nach Best subset selection verglichen. Diese Modelle werden sodann mit den 29-Variablen-Modellen verglichen.
Teilmengenauswahl für das 24-Variablen-Modell
final_best_WG2_24 <- regsubsets(Umsatz ~ ., data = df_lm_train_WG2, nvmax = 37)
coef(final_best_WG2_24, 24)## (Intercept) KielerWoche Temperatur
## 253.991013 99.330538 1.444194
## Windgeschwindigkeit Wochentag_cFreitag Wochentag_cSamstag
## 1.018136 16.102352 104.533282
## Wochentag_cSonntag Monat_cAugust Monat_cDezember
## 159.530591 55.287643 33.123450
## Monat_cJuli Monat_cJuni Monat_cMai
## 64.625104 54.435465 40.897683
## Monat_cNovember Monat_cOktober Monat_cSeptember
## 25.758081 104.862197 64.873315
## SommerferienSH SommerferienNRW SommerferienNDS
## 49.518634 87.740027 28.669983
## SommerferienHE Feiertag Ostern_ext
## 50.834005 74.165151 229.519850
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 87.841329 65.552466 141.775252
## JahreszeitHerbst
## -53.857328
Die 24 Variablen sind die folgenden:
- KielerWoche
- Temperatur
- Windgeschwindigkeit
- Wochentag_cFreitag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cAugust
- Monat_cDezember
- Monat_cJuli
- Monat_cJuni
- Monat_cMai
- Monat_cNovember
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- Silvester_ext
- JahreszeitHerbst
Die Variablen Wochentag_c, Monat und Jahreszeit nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG2_24 <- df_lm_train_WG2 %>%
mutate(Montag=as.integer(df_lm_train_WG2$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG2$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG2$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG2$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG2$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG2$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG2$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG2$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG2$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG2$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG2$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG2$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG2$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG2$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG2$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG2$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG2$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG2$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG2$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG2$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG2$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG2$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG2$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG2_24 <- df_lm_test_WG2 %>%
mutate(Montag=as.integer(df_lm_test_WG2$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG2$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG2$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG2$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG2$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG2$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG2$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG2$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG2$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG2$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG2$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG2$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG2$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG2$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG2$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG2$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG2$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG2$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG2$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG2$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG2$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG2$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG2$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 24-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG2_24_train <- lm(Umsatz ~ KielerWoche + Temperatur + Windgeschwindigkeit + Freitag + Samstag + Sonntag + August + Dezember + Juli + Juni + Mai + November + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienNDS + SommerferienHE + Feiertag + Ostern_ext + ChristiHimmelfahrt_ext + Silvester_ext + Herbst, data = df_lm_train_WG2_24)
glance(lm_WG2_24_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.831 0.828 50.9 222. 0 24 -5663. 11376.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 52.0427195 0.8401238 39.7876993
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG2_24 <- df_lm_test_WG2_24 %>%
mutate(predicted = lm_WG2_24_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG2_24 <- df_lm_test_WG2_24 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG2_24 <-df_lm_test_WG2_24 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG2_24 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best24_WG2")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 5 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7 24.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6 24.7
## 3 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4 24.5
## 4 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4 24.5
## 5 346 130413. 377. 39.8 3.37 11.4 10.6 2708. 52.0 13.8
## # ... with 1 more variable: Modell <chr>
Teilmengenauswahl für das 32-Variablen-Modell
Die 32 Variablen sind die folgenden:
- KielerWoche
- Bewoelkung
- Temperatur
- Windgeschwindigkeit
- Wochentag_cFreitag
- Wochentag_cMittwoch
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cAugust
- Monat_cDezember
- Monat_cFebruar
- Monat_cJuli
- Monat_cJuni
- Monat_cMai
- Monat_cNovember
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- Silvester_ext
- JahreszeitHerbst
- JahreszeitSommer
- JahreszeitWinter
Die Variablen Wochentag_c, Monat_c und Jahreszeit nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG2_32 <- df_lm_train_WG2 %>%
mutate(Montag=as.integer(df_lm_train_WG2$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG2$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG2$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG2$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG2$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG2$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG2$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG2$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG2$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG2$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG2$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG2$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG2$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG2$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG2$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG2$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG2$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG2$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG2$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG2$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG2$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG2$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG2$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG2_32 <- df_lm_test_WG2 %>%
mutate(Montag=as.integer(df_lm_test_WG2$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG2$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG2$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG2$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG2$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG2$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG2$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG2$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG2$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG2$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG2$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG2$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG2$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG2$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG2$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG2$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG2$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG2$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG2$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG2$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG2$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG2$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG2$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 32-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG2_32_train <- lm(Umsatz ~ KielerWoche + Bewoelkung + Temperatur + Windgeschwindigkeit + Freitag + Mittwoch + Samstag + Sonntag + August + Dezember + Februar + Juli + Juni + Mai + November + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienNDS + SommerferienHE + Feiertag + ChristiHimmelfahrt + Pfingsten + TDE + Ostern_ext + ChristiHimmelfahrt_ext + Pfingsten_ext + Silvester_ext + Herbst + Sommer + Winter, data = df_lm_train_WG2_32)
glance(lm_WG2_32_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.837 0.832 50.3 165. 0 33 -5645. 11358.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 52.1755124 0.8391912 39.8508235
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG2_32 <- df_lm_test_WG2_32 %>%
mutate(predicted = lm_WG2_32_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG2_32 <- df_lm_test_WG2_32 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG2_32 <-df_lm_test_WG2_32 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG2_32 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best32_WG2")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 6 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7 24.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6 24.7
## 3 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4 24.5
## 4 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4 24.5
## 5 346 130413. 377. 39.8 3.37 11.4 10.6 2708. 52.0 13.8
## 6 346 130413. 377. 39.8 3.45 11.4 10.6 2722. 52.2 13.8
## # ... with 1 more variable: Modell <chr>
Teilmengenauswahl für die 29-Variablen-Modelle
Die 29 Variablen nach best subset selection sind die folgenden:
- KielerWoche
- Bewoelkung
- Windgeschwindigkeit
- Wochentag_cFreitag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cAugust
- Monat_cDezember
- Monat_cJuli
- Monat_cJuni
- Monat_cMai
- Monat_cNovember
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- Silvester_ext
- JahreszeitHerbst
- Wochentag_cMittwoch
- Monat_cFebruar
- Ostern
- JahreszeitSommer
- JahreszeitWinter
Die Variablen Wochentag_c, Monat und Jahreszeit nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG2_29 <- df_lm_train_WG2 %>%
mutate(Montag=as.integer(df_lm_train_WG2$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG2$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG2$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG2$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG2$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG2$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG2$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG2$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG2$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG2$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG2$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG2$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG2$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG2$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG2$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG2$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG2$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG2$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG2$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG2$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG2$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG2$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG2$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG2_29 <- df_lm_test_WG2 %>%
mutate(Montag=as.integer(df_lm_test_WG2$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG2$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG2$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG2$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG2$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG2$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG2$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG2$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG2$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG2$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG2$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG2$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG2$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG2$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG2$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG2$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG2$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG2$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG2$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG2$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG2$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG2$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG2$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 29-Variablenmodell nach best subset selection wird nun ein Regressionsmodell erstellt:
lm_WG2_29_train_bss <- lm(Umsatz ~ KielerWoche + Bewoelkung + Windgeschwindigkeit + Freitag + Mittwoch + Samstag + Sonntag + August + Dezember + Februar + Juli + Juni + Mai + November + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienNDS + SommerferienHE + Feiertag + Ostern + Ostern_ext + ChristiHimmelfahrt_ext + Pfingsten_ext + Silvester_ext + Herbst + Sommer + Winter, data = df_lm_train_WG2_29)
glance(lm_WG2_29_train_bss)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.836 0.832 50.3 182. 0 30 -5647. 11356.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 52.6093893 0.8366408 40.2665701
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG2_29 <- df_lm_test_WG2_29 %>%
mutate(predicted_bss = lm_WG2_29_predict_bss)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG2_29 <- df_lm_test_WG2_29 %>%
mutate(Prognose_zuhoch = (predicted_bss >= Umsatz)) %>%
mutate(Abweichung = predicted_bss - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted_bss - Umsatz)) %>%
mutate(Abweichung_rel = (predicted_bss - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG2_29 <-df_lm_test_WG2_29 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG2_29 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best29_bss_WG2")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 7 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7 24.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6 24.7
## 3 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4 24.5
## 4 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4 24.5
## 5 346 130413. 377. 39.8 3.37 11.4 10.6 2708. 52.0 13.8
## 6 346 130413. 377. 39.8 3.45 11.4 10.6 2722. 52.2 13.8
## 7 346 130413. 377. 40.3 3.48 11.6 10.7 2768. 52.6 14.0
## # ... with 1 more variable: Modell <chr>
Zum Vergleich wird nun ein Regressionsmodell für das 29-Variablenmodell nach backward selection erstellt:
lm_WG2_29_train_back <- lm(Umsatz ~ KielerWoche + Temperatur + Bewoelkung + Windgeschwindigkeit + Donnerstag + Montag + Freitag + Samstag + Sonntag + August + Dezember + Januar + Maerz + Juli + Juni + Mai + November + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienNDS + SommerferienHE + Feiertag + Ostern_ext + ChristiHimmelfahrt_ext + Pfingsten_ext + Silvester_ext + Herbst, data = df_lm_train_WG2_29)
glance(lm_WG2_29_train_back)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.836 0.831 50.3 181. 0 30 -5648. 11358.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 52.1542506 0.8394304 39.8687151
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG2_29 <- df_lm_test_WG2_29 %>%
mutate(predicted_back = lm_WG2_29_predict_back)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG2_29 <- df_lm_test_WG2_29 %>%
mutate(Prognose_zuhoch = (predicted_back >= Umsatz)) %>%
mutate(Abweichung = predicted_back - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted_back - Umsatz)) %>%
mutate(Abweichung_rel = (predicted_back - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG2_29 <-df_lm_test_WG2_29 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG2_29 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best29_back_WG2")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 8 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7 24.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6 24.7
## 3 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4 24.5
## 4 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4 24.5
## 5 346 130413. 377. 39.8 3.37 11.4 10.6 2708. 52.0 13.8
## 6 346 130413. 377. 39.8 3.45 11.4 10.6 2722. 52.2 13.8
## 7 346 130413. 377. 40.3 3.48 11.6 10.7 2768. 52.6 14.0
## 8 346 130413. 377. 39.9 3.52 11.5 10.6 2720. 52.2 13.8
## # ... with 1 more variable: Modell <chr>
Auch wenn es nur marginale Unterschiede zwischen den Performances der einzelnen Modelle gibt, performt abschließend das 24-Variablen-Modell am besten. da generell schlankere Modelle bevorzugt werden sollten, fällt die Wahl auf das genannte Modell.
Folgende Variablen sind also am besten geeignet, um Prognosen für die Umsätze in der Warengruppe 2 zu erstellen:
- KielerWoche
- Temperatur
- Windgeschwindigkeit
- Wochentage:
- Freitag
- Samstag
- Sonntag
- Monate:
- August
- Dezember
- Juli
- Juni
- Mai
- November
- Oktober
- September
- Sommerferien:
- SH
- NRW
- NDS
- HE
- Feiertag
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- Silvester_ext
- Jahreszeit:
- Herbst
6.3.3 Warengruppe 3
Erstellung von Trainings- und Testdatensätzen für Warengruppe 3
df_lm_train_WG3 <- df_lm_train %>% filter(Warengruppe == "3")
df_lm_train_WG3 <- na.omit(df_lm_train_WG3)
df_lm_train_WG3 <- df_lm_train_WG3 %>% dplyr::select(-Warengruppe)
df_lm_test_WG3 <- df_lm_test %>% filter(Warengruppe == "3")
df_lm_test_WG3 <- na.omit(df_lm_test_WG3)
df_lm_test_WG3 <- df_lm_test_WG3 %>% dplyr::select(-Warengruppe)Auswahl der am besten geeigneten Variablen Was die Vorgehensweise und die enstsprechenden Erläuterungen anbelangt, siehe 6.3.1.
Beste Teilmengenauswahl (“Best subset selection”)
Die regsubsets-Funktion gibt ein Listenobjekt mit vielen Informationen zurück. Zunächst kann der Befehl summary verwendet, um den besten Satz von Variablen für jede Modellgröße zu ermitteln.
## Subset selection object
## Call: regsubsets.formula(Umsatz ~ ., df_lm_train_WG3, nvmax = 37)
## 37 Variables (and intercept)
## Forced in Forced out
## KielerWoche FALSE FALSE
## Bewoelkung FALSE FALSE
## Temperatur FALSE FALSE
## Windgeschwindigkeit FALSE FALSE
## Wochentag_cDonnerstag FALSE FALSE
## Wochentag_cFreitag FALSE FALSE
## Wochentag_cMittwoch FALSE FALSE
## Wochentag_cMontag FALSE FALSE
## Wochentag_cSamstag FALSE FALSE
## Wochentag_cSonntag FALSE FALSE
## Monat_cAugust FALSE FALSE
## Monat_cDezember FALSE FALSE
## Monat_cFebruar FALSE FALSE
## Monat_cJanuar FALSE FALSE
## Monat_cJuli FALSE FALSE
## Monat_cJuni FALSE FALSE
## Monat_cMai FALSE FALSE
## Monat_cMärz FALSE FALSE
## Monat_cNovember FALSE FALSE
## Monat_cOktober FALSE FALSE
## Monat_cSeptember FALSE FALSE
## SommerferienSH FALSE FALSE
## SommerferienNRW FALSE FALSE
## SommerferienNDS FALSE FALSE
## SommerferienHE FALSE FALSE
## Feiertag FALSE FALSE
## Ostern FALSE FALSE
## ChristiHimmelfahrt FALSE FALSE
## Pfingsten FALSE FALSE
## TDE FALSE FALSE
## Ostern_ext FALSE FALSE
## ChristiHimmelfahrt_ext FALSE FALSE
## Pfingsten_ext FALSE FALSE
## Silvester_ext FALSE FALSE
## JahreszeitHerbst FALSE FALSE
## JahreszeitSommer FALSE FALSE
## JahreszeitWinter FALSE FALSE
## 1 subsets of each size up to 37
## Selection Algorithm: exhaustive
## KielerWoche Bewoelkung Temperatur Windgeschwindigkeit
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " "*" " "
## 3 ( 1 ) " " " " "*" " "
## 4 ( 1 ) " " " " "*" " "
## 5 ( 1 ) " " " " "*" " "
## 6 ( 1 ) " " " " "*" " "
## 7 ( 1 ) "*" " " "*" " "
## 8 ( 1 ) "*" " " "*" " "
## 9 ( 1 ) "*" " " "*" " "
## 10 ( 1 ) "*" " " "*" " "
## 11 ( 1 ) "*" " " "*" " "
## 12 ( 1 ) "*" " " "*" " "
## 13 ( 1 ) "*" " " "*" " "
## 14 ( 1 ) "*" " " "*" " "
## 15 ( 1 ) "*" " " "*" " "
## 16 ( 1 ) "*" " " "*" " "
## 17 ( 1 ) "*" " " "*" " "
## 18 ( 1 ) "*" " " "*" " "
## 19 ( 1 ) "*" " " "*" " "
## 20 ( 1 ) "*" " " "*" " "
## 21 ( 1 ) "*" "*" "*" " "
## 22 ( 1 ) "*" " " "*" " "
## 23 ( 1 ) "*" "*" "*" " "
## 24 ( 1 ) "*" "*" "*" " "
## 25 ( 1 ) "*" "*" "*" " "
## 26 ( 1 ) "*" "*" " " " "
## 27 ( 1 ) "*" "*" " " " "
## 28 ( 1 ) "*" "*" " " " "
## 29 ( 1 ) "*" "*" " " " "
## 30 ( 1 ) "*" "*" "*" " "
## 31 ( 1 ) "*" "*" "*" " "
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## Wochentag_cDonnerstag Wochentag_cFreitag Wochentag_cMittwoch
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " " "
## 9 ( 1 ) " " " " " "
## 10 ( 1 ) " " " " " "
## 11 ( 1 ) " " " " " "
## 12 ( 1 ) " " " " " "
## 13 ( 1 ) " " " " " "
## 14 ( 1 ) " " " " " "
## 15 ( 1 ) " " " " " "
## 16 ( 1 ) " " " " " "
## 17 ( 1 ) " " " " " "
## 18 ( 1 ) " " " " " "
## 19 ( 1 ) " " " " " "
## 20 ( 1 ) " " " " " "
## 21 ( 1 ) " " " " " "
## 22 ( 1 ) " " " " " "
## 23 ( 1 ) " " " " " "
## 24 ( 1 ) " " "*" " "
## 25 ( 1 ) " " "*" " "
## 26 ( 1 ) " " " " " "
## 27 ( 1 ) " " "*" " "
## 28 ( 1 ) " " "*" " "
## 29 ( 1 ) " " "*" " "
## 30 ( 1 ) " " "*" " "
## 31 ( 1 ) " " "*" " "
## 32 ( 1 ) " " "*" " "
## 33 ( 1 ) "*" "*" " "
## 34 ( 1 ) "*" "*" " "
## 35 ( 1 ) "*" "*" " "
## 36 ( 1 ) "*" "*" " "
## 37 ( 1 ) "*" "*" "*"
## Wochentag_cMontag Wochentag_cSamstag Wochentag_cSonntag
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " "*"
## 4 ( 1 ) " " "*" "*"
## 5 ( 1 ) " " "*" "*"
## 6 ( 1 ) " " "*" "*"
## 7 ( 1 ) " " "*" "*"
## 8 ( 1 ) " " "*" "*"
## 9 ( 1 ) " " "*" "*"
## 10 ( 1 ) " " "*" "*"
## 11 ( 1 ) " " "*" "*"
## 12 ( 1 ) " " "*" "*"
## 13 ( 1 ) " " "*" "*"
## 14 ( 1 ) " " "*" "*"
## 15 ( 1 ) " " "*" "*"
## 16 ( 1 ) " " "*" "*"
## 17 ( 1 ) " " "*" "*"
## 18 ( 1 ) " " "*" "*"
## 19 ( 1 ) " " "*" "*"
## 20 ( 1 ) " " "*" "*"
## 21 ( 1 ) " " "*" "*"
## 22 ( 1 ) " " "*" "*"
## 23 ( 1 ) " " "*" "*"
## 24 ( 1 ) " " "*" "*"
## 25 ( 1 ) " " "*" "*"
## 26 ( 1 ) " " "*" "*"
## 27 ( 1 ) " " "*" "*"
## 28 ( 1 ) " " "*" "*"
## 29 ( 1 ) "*" "*" "*"
## 30 ( 1 ) "*" "*" "*"
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
## Monat_cAugust Monat_cDezember Monat_cFebruar Monat_cJanuar
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " " " " "
## 8 ( 1 ) " " " " " " " "
## 9 ( 1 ) " " " " " " " "
## 10 ( 1 ) " " " " " " " "
## 11 ( 1 ) " " " " " " " "
## 12 ( 1 ) " " " " " " " "
## 13 ( 1 ) " " " " " " " "
## 14 ( 1 ) " " " " " " " "
## 15 ( 1 ) " " " " " " " "
## 16 ( 1 ) " " " " " " " "
## 17 ( 1 ) " " " " " " " "
## 18 ( 1 ) " " " " " " " "
## 19 ( 1 ) " " " " "*" "*"
## 20 ( 1 ) " " " " "*" "*"
## 21 ( 1 ) " " " " "*" "*"
## 22 ( 1 ) " " " " "*" " "
## 23 ( 1 ) " " " " "*" " "
## 24 ( 1 ) " " " " "*" " "
## 25 ( 1 ) " " " " "*" "*"
## 26 ( 1 ) "*" " " "*" "*"
## 27 ( 1 ) "*" " " "*" "*"
## 28 ( 1 ) "*" " " "*" "*"
## 29 ( 1 ) "*" " " "*" "*"
## 30 ( 1 ) "*" " " "*" "*"
## 31 ( 1 ) "*" " " "*" "*"
## 32 ( 1 ) "*" " " "*" "*"
## 33 ( 1 ) "*" " " "*" "*"
## 34 ( 1 ) "*" " " "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## Monat_cJuli Monat_cJuni Monat_cMai Monat_cMärz Monat_cNovember
## 1 ( 1 ) " " " " " " " " " "
## 2 ( 1 ) " " " " " " " " " "
## 3 ( 1 ) " " " " " " " " " "
## 4 ( 1 ) " " " " " " " " " "
## 5 ( 1 ) " " " " " " " " " "
## 6 ( 1 ) " " " " " " " " " "
## 7 ( 1 ) " " " " " " " " " "
## 8 ( 1 ) " " " " " " " " " "
## 9 ( 1 ) " " " " " " " " " "
## 10 ( 1 ) " " " " " " " " " "
## 11 ( 1 ) " " " " " " " " " "
## 12 ( 1 ) " " " " " " " " " "
## 13 ( 1 ) " " " " " " " " " "
## 14 ( 1 ) " " " " " " " " " "
## 15 ( 1 ) " " " " " " " " " "
## 16 ( 1 ) " " " " " " " " " "
## 17 ( 1 ) " " " " " " "*" " "
## 18 ( 1 ) " " " " " " "*" " "
## 19 ( 1 ) " " " " " " "*" " "
## 20 ( 1 ) " " "*" " " "*" " "
## 21 ( 1 ) " " "*" " " "*" " "
## 22 ( 1 ) " " "*" " " "*" " "
## 23 ( 1 ) " " "*" " " "*" " "
## 24 ( 1 ) " " "*" " " "*" " "
## 25 ( 1 ) " " "*" " " "*" " "
## 26 ( 1 ) "*" "*" "*" "*" " "
## 27 ( 1 ) "*" "*" "*" "*" " "
## 28 ( 1 ) "*" "*" "*" "*" " "
## 29 ( 1 ) "*" "*" "*" "*" " "
## 30 ( 1 ) "*" "*" "*" "*" " "
## 31 ( 1 ) "*" "*" "*" "*" " "
## 32 ( 1 ) "*" "*" "*" "*" " "
## 33 ( 1 ) "*" "*" "*" "*" " "
## 34 ( 1 ) "*" "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*" "*"
## Monat_cOktober Monat_cSeptember SommerferienSH SommerferienNRW
## 1 ( 1 ) " " " " " " "*"
## 2 ( 1 ) " " " " " " "*"
## 3 ( 1 ) " " " " " " "*"
## 4 ( 1 ) " " " " " " "*"
## 5 ( 1 ) " " " " " " "*"
## 6 ( 1 ) " " " " " " "*"
## 7 ( 1 ) " " " " " " "*"
## 8 ( 1 ) " " " " " " "*"
## 9 ( 1 ) " " " " "*" "*"
## 10 ( 1 ) "*" " " "*" "*"
## 11 ( 1 ) "*" " " "*" "*"
## 12 ( 1 ) "*" " " "*" "*"
## 13 ( 1 ) "*" " " "*" "*"
## 14 ( 1 ) "*" " " "*" "*"
## 15 ( 1 ) "*" " " "*" "*"
## 16 ( 1 ) "*" "*" "*" "*"
## 17 ( 1 ) "*" "*" "*" "*"
## 18 ( 1 ) "*" "*" "*" "*"
## 19 ( 1 ) "*" "*" "*" "*"
## 20 ( 1 ) "*" "*" "*" "*"
## 21 ( 1 ) "*" "*" "*" "*"
## 22 ( 1 ) "*" "*" "*" "*"
## 23 ( 1 ) "*" "*" "*" "*"
## 24 ( 1 ) "*" "*" "*" "*"
## 25 ( 1 ) "*" "*" "*" "*"
## 26 ( 1 ) "*" "*" "*" "*"
## 27 ( 1 ) "*" "*" "*" "*"
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## SommerferienNDS SommerferienHE Feiertag Ostern
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " "*" " " " "
## 6 ( 1 ) " " "*" " " " "
## 7 ( 1 ) " " "*" " " " "
## 8 ( 1 ) " " "*" " " " "
## 9 ( 1 ) " " "*" " " " "
## 10 ( 1 ) " " "*" " " " "
## 11 ( 1 ) " " "*" " " " "
## 12 ( 1 ) " " "*" " " " "
## 13 ( 1 ) " " "*" " " " "
## 14 ( 1 ) " " "*" " " " "
## 15 ( 1 ) "*" "*" " " " "
## 16 ( 1 ) "*" "*" " " " "
## 17 ( 1 ) "*" "*" " " " "
## 18 ( 1 ) "*" "*" " " " "
## 19 ( 1 ) "*" "*" "*" "*"
## 20 ( 1 ) "*" "*" "*" "*"
## 21 ( 1 ) "*" "*" "*" "*"
## 22 ( 1 ) "*" "*" " " "*"
## 23 ( 1 ) "*" "*" " " "*"
## 24 ( 1 ) "*" "*" " " "*"
## 25 ( 1 ) "*" "*" " " "*"
## 26 ( 1 ) "*" "*" " " "*"
## 27 ( 1 ) "*" "*" " " "*"
## 28 ( 1 ) "*" "*" " " "*"
## 29 ( 1 ) "*" "*" " " "*"
## 30 ( 1 ) "*" "*" " " "*"
## 31 ( 1 ) "*" "*" " " "*"
## 32 ( 1 ) "*" "*" " " "*"
## 33 ( 1 ) "*" "*" " " "*"
## 34 ( 1 ) "*" "*" " " "*"
## 35 ( 1 ) "*" "*" " " "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## ChristiHimmelfahrt Pfingsten TDE Ostern_ext
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " "*"
## 7 ( 1 ) " " " " " " "*"
## 8 ( 1 ) " " "*" " " "*"
## 9 ( 1 ) " " "*" " " "*"
## 10 ( 1 ) " " "*" " " "*"
## 11 ( 1 ) " " "*" " " "*"
## 12 ( 1 ) " " "*" " " "*"
## 13 ( 1 ) " " "*" " " "*"
## 14 ( 1 ) " " "*" " " "*"
## 15 ( 1 ) " " "*" " " "*"
## 16 ( 1 ) " " "*" " " "*"
## 17 ( 1 ) " " "*" " " "*"
## 18 ( 1 ) " " "*" " " "*"
## 19 ( 1 ) " " " " " " "*"
## 20 ( 1 ) " " " " " " "*"
## 21 ( 1 ) " " " " " " "*"
## 22 ( 1 ) " " "*" "*" "*"
## 23 ( 1 ) " " "*" "*" "*"
## 24 ( 1 ) " " "*" "*" "*"
## 25 ( 1 ) " " "*" "*" "*"
## 26 ( 1 ) " " "*" "*" "*"
## 27 ( 1 ) " " "*" "*" "*"
## 28 ( 1 ) " " "*" "*" "*"
## 29 ( 1 ) " " "*" "*" "*"
## 30 ( 1 ) " " "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " " "
## 9 ( 1 ) " " " " " "
## 10 ( 1 ) " " " " " "
## 11 ( 1 ) " " " " " "
## 12 ( 1 ) "*" " " " "
## 13 ( 1 ) "*" " " " "
## 14 ( 1 ) "*" " " "*"
## 15 ( 1 ) "*" " " "*"
## 16 ( 1 ) "*" " " "*"
## 17 ( 1 ) "*" " " "*"
## 18 ( 1 ) "*" "*" "*"
## 19 ( 1 ) "*" "*" " "
## 20 ( 1 ) "*" "*" " "
## 21 ( 1 ) "*" "*" " "
## 22 ( 1 ) "*" "*" "*"
## 23 ( 1 ) "*" "*" "*"
## 24 ( 1 ) "*" "*" "*"
## 25 ( 1 ) "*" "*" "*"
## 26 ( 1 ) "*" "*" "*"
## 27 ( 1 ) "*" "*" "*"
## 28 ( 1 ) "*" "*" "*"
## 29 ( 1 ) "*" "*" "*"
## 30 ( 1 ) "*" "*" "*"
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
## JahreszeitHerbst JahreszeitSommer JahreszeitWinter
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " " "
## 9 ( 1 ) " " " " " "
## 10 ( 1 ) " " " " " "
## 11 ( 1 ) "*" " " " "
## 12 ( 1 ) "*" " " " "
## 13 ( 1 ) "*" " " "*"
## 14 ( 1 ) "*" " " "*"
## 15 ( 1 ) "*" " " "*"
## 16 ( 1 ) "*" " " "*"
## 17 ( 1 ) "*" " " "*"
## 18 ( 1 ) "*" " " "*"
## 19 ( 1 ) "*" " " " "
## 20 ( 1 ) "*" " " " "
## 21 ( 1 ) "*" " " " "
## 22 ( 1 ) "*" " " "*"
## 23 ( 1 ) "*" " " "*"
## 24 ( 1 ) "*" " " "*"
## 25 ( 1 ) "*" " " "*"
## 26 ( 1 ) "*" " " "*"
## 27 ( 1 ) "*" " " "*"
## 28 ( 1 ) "*" "*" "*"
## 29 ( 1 ) "*" "*" "*"
## 30 ( 1 ) "*" "*" "*"
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
Für ein Modell mit einer Variablen kann beobachtet werden, dass die erzeugte Dummy-Variable SommerferienNRW ein Sternchen hat, was signalisiert, dass ein Regressionsmodell mit Umsatz ~ SommerferienNRW das beste Einzelvariablenmodell ist. Das beste 2-Variablen-Modell ist Umsatz ~ SommerferienNRW + Temperatur. Das beste 3-Variablen-Modell ist Umsatz ~ SommerferienNRW + Temperatur + Wochentag_cSonntag. Beim 4-Variablen-Modell wird der Wochentag_cSamstag hinzugefügt.
Modellauswahl
Indirekte Schätzung des Testfehlers mit \(C_{p}\), \(AIC\), \(BIC\) und adjustiertem \(R^2\)
results <- summary(best_subset_WG3)
# Extrahieren und plotten der Ergebnisse
tibble(predictors = 1:37,
adj_R2 = results$adjr2,
Cp = results$cp,
BIC = results$bic) %>%
gather(statistic, value, -predictors) %>%
ggplot(aes(predictors, value, color = statistic)) +
geom_line(show.legend = F) +
geom_point(show.legend = F) +
facet_wrap(~ statistic, scales = "free")## [1] 30
## [1] 20
## [1] 28
Es ist erkennbar, dass die Ergebnisse leicht unterschiedliche Modelle identifizieren, die als die besten angesehen werden. Die ajustierte \(R^2\)-Statistik legt nahe, dass das 30-Variablen-Modell bevorzugt wird, die \(BIC\)-Statistik schlägt das 20-Variablenmodell vor und der \(C_{p}\) das 28-Variablen-Modell vor.
Der gleiche Prozess kann durch schrittweise Vorwärts- und Rückwärtsauswahl durchgeführt werden, um noch mehr Optionen für optimale Modelle zu erhalten:
forward <- regsubsets(Umsatz ~ ., df_lm_train_WG3, nvmax = 37, method = "forward")
backward <- regsubsets(Umsatz ~ ., df_lm_train_WG3, nvmax = 37, method = "backward")
# Welches Modell minimiert den Cp?
which.min(summary(forward)$cp)## [1] 29
## [1] 28
Wenn man das optimale \(C_{p}\) für vorwärts und rückwärts schrittweise bewertet, ist erkennbar, dass gemäß der Vorwärts-Methode ein 29-Variablen-Modell die \(C_{p}\)-Statistik minimiert. Die Rückwärtsmethode schlägt ein 28-Variablen-Modell vor.
Wenn wir die Koeffizienten dieser Modelle bewerten, ergibt sich bzgl. der Zusammensetzung der Prädikatoren folgendes Bild:
## (Intercept) KielerWoche Temperatur
## 106.0471994 47.6753392 0.9400878
## Wochentag_cSamstag Wochentag_cSonntag Monat_cFebruar
## 48.3118671 54.7014514 -22.9256947
## Monat_cJanuar Monat_cJuni Monat_cMärz
## -15.9842631 11.5002351 -20.2984903
## Monat_cOktober Monat_cSeptember SommerferienSH
## 44.3266560 16.4473488 39.4563302
## SommerferienNRW SommerferienNDS SommerferienHE
## 60.8392704 17.8177016 45.6218462
## Feiertag Ostern Ostern_ext
## 39.5942375 -80.4956376 126.1742444
## ChristiHimmelfahrt_ext Pfingsten_ext JahreszeitHerbst
## 49.1599377 45.9086916 -27.2939939
Folgende Variablen werden in das 20-Variablen-Modell integriert:
- KielerWoche
- Temperatur
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cFebruar
- Monat_cJanuar
- Monat_cJuni
- Monat_cMärz
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- Ostern
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- JahreszeitHerbst
## (Intercept) KielerWoche Bewoelkung
## 117.2396203 53.6097207 -0.9290962
## Wochentag_cFreitag Wochentag_cSamstag Wochentag_cSonntag
## 4.2772419 48.6671722 54.8805645
## Monat_cAugust Monat_cFebruar Monat_cJanuar
## 25.6249105 -16.9913859 -11.3979256
## Monat_cJuli Monat_cJuni Monat_cMai
## 27.0553148 22.5209100 8.6528684
## Monat_cMärz Monat_cOktober Monat_cSeptember
## -14.9778010 49.9197054 31.3776962
## SommerferienSH SommerferienNRW SommerferienNDS
## 37.7613398 56.7176167 16.5848019
## SommerferienHE Ostern Pfingsten
## 44.0127943 -40.7850255 58.1798104
## TDE Ostern_ext ChristiHimmelfahrt_ext
## 45.2020603 125.2800213 54.4629528
## Pfingsten_ext Silvester_ext JahreszeitHerbst
## 34.0208217 42.9623673 -28.7913280
## JahreszeitSommer JahreszeitWinter
## -8.3757382 -8.7783715
Beim 28-Variablen-Modell werden folgende Variablen aufgenommen:
- KielerWoche
- Bewoelkung
- Wochentag_cFreitag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cAugust
- Monat_cFebruar
- Monat_cJanuar
- Monat_cJuli
- Monat_cJuni
- Monat_cMai
- Monat_cMärz
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Ostern
- Pfingsten
- TDE
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- Silvester_ext
- JahreszeitHerbst
- JahreszeitSommer
- JahreszeitWinter
## (Intercept) KielerWoche Bewoelkung
## 112.1340426 52.9972328 -0.7861647
## Temperatur Wochentag_cFreitag Wochentag_cMontag
## 0.3622229 5.1432788 3.6969705
## Wochentag_cSamstag Wochentag_cSonntag Monat_cAugust
## 49.5722868 55.8128039 21.7290071
## Monat_cFebruar Monat_cJanuar Monat_cJuli
## -16.2297545 -10.1105643 23.4708693
## Monat_cJuni Monat_cMai Monat_cMärz
## 19.5138212 6.6355873 -14.9282982
## Monat_cOktober Monat_cSeptember SommerferienSH
## 48.0702081 28.1323766 37.9685573
## SommerferienNRW SommerferienNDS SommerferienHE
## 56.4189768 16.2955412 43.9650470
## Ostern Pfingsten TDE
## -42.6545012 56.6706858 43.7846082
## Ostern_ext ChristiHimmelfahrt_ext Pfingsten_ext
## 126.2327204 54.5661728 34.9534977
## Silvester_ext JahreszeitHerbst JahreszeitSommer
## 43.7544943 -27.8237783 -8.0168561
## JahreszeitWinter
## -7.5948847
Im 30-Variablen-Modell werden die beiden Variablen Temperatur und Wochentag_cMontag ergänzt.
## (Intercept) KielerWoche Bewoelkung
## 113.0039067 53.0429430 -0.7884231
## Temperatur Wochentag_cFreitag Wochentag_cSamstag
## 0.3609494 4.2571491 48.6956381
## Wochentag_cSonntag Monat_cAugust Monat_cFebruar
## 54.8641906 21.8432355 -15.9167225
## Monat_cJanuar Monat_cJuli Monat_cJuni
## -9.8121360 23.5284206 19.5390215
## Monat_cMai Monat_cMärz Monat_cOktober
## 6.7356599 -14.7731313 48.0705731
## Monat_cSeptember SommerferienSH SommerferienNRW
## 28.1774605 37.9294906 56.4839249
## SommerferienNDS SommerferienHE Ostern
## 16.3676873 43.8671201 -40.8766030
## Pfingsten TDE Ostern_ext
## 58.5509859 44.4065768 125.8774918
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 54.1656236 34.4787097 43.7198145
## JahreszeitHerbst JahreszeitSommer JahreszeitWinter
## -27.7626016 -8.0340646 -7.8114667
## (Intercept) KielerWoche Bewoelkung
## 117.2396204 53.6097206 -0.9290962
## Wochentag_cFreitag Wochentag_cSamstag Wochentag_cSonntag
## 4.2772419 48.6671722 54.8805645
## Monat_cAugust Monat_cFebruar Monat_cJanuar
## 25.6249105 -16.9913859 -11.3979257
## Monat_cJuli Monat_cJuni Monat_cMai
## 27.0553148 22.5209100 8.6528684
## Monat_cMärz Monat_cOktober Monat_cSeptember
## -14.9778010 49.9197054 31.3776961
## SommerferienSH SommerferienNRW SommerferienNDS
## 37.7613398 56.7176166 16.5848019
## SommerferienHE Ostern Pfingsten
## 44.0127943 -40.7850253 58.1798102
## TDE Ostern_ext ChristiHimmelfahrt_ext
## 45.2020604 125.2800212 54.4629528
## Pfingsten_ext Silvester_ext JahreszeitHerbst
## 34.0208217 42.9623672 -28.7913280
## JahreszeitSommer JahreszeitWinter
## -8.3757382 -8.7783715
Die Modelle unterscheiden sich nur marginal von denen der best subset selection.
Direkte Schätzung des Testfehlers
Nun wird der Fehler der Testdaten für das beste Modell jeder Modellgröße berechnet. Zuerst wird eine Modellmatrix aus den Testdaten erstellt. Die Funktion model.matrix wird in vielen Regressionspaketen zum Erstellen einer X-Matrix aus Daten verwendet.
Jetzt kann jede Modellgröße (d.h. 1 Variable, 2 Variablen,…, 20 Variablen) durchlaufen werden und die Koeffizienten für das beste Modell dieser Größe extrahiert werden. Diese Werte werden sodann in die entsprechenden Spalten der Testmodellmatrix multipliziert, um die Vorhersagen zu bilden. Dann werden die Test-MSE berechnet.
# Erstellen eines leeren Vektors, um diesen nachfolgend mit den Fehlerwerten zu füllen
validation_errors <- vector("double", length = 37)
for(i in 1:37) {
coef_x <- coef(best_subset_WG3, id = i) # extract coefficients for model size i
pred_x <- test_m[ , names(coef_x)] %*% coef_x # predict salary using matrix algebra
validation_errors[i] <- mean((df_lm_test_WG3$Umsatz - pred_x)^2) # compute test error btwn actual & predicted salary
}
as.matrix(validation_errors)## [,1]
## [1,] 4348.738
## [2,] 3376.739
## [3,] 2718.970
## [4,] 2228.789
## [5,] 2193.722
## [6,] 2066.863
## [7,] 2015.831
## [8,] 2014.283
## [9,] 1857.352
## [10,] 1821.443
## [11,] 1852.143
## [12,] 1805.983
## [13,] 1836.865
## [14,] 1785.291
## [15,] 1757.158
## [16,] 1770.338
## [17,] 1788.553
## [18,] 1778.665
## [19,] 1733.495
## [20,] 1753.647
## [21,] 1744.054
## [22,] 1760.097
## [23,] 1751.844
## [24,] 1742.633
## [25,] 1733.022
## [26,] 1749.919
## [27,] 1740.599
## [28,] 1737.503
## [29,] 1739.846
## [30,] 1722.270
## [31,] 1721.400
## [32,] 1720.616
## [33,] 1723.854
## [34,] 1722.438
## [35,] 1716.123
## [36,] 1715.292
## [37,] 1715.364
#############################
# Alternative: http://www.science.smith.edu/~jcrouser/SDS293/labs/lab9-r.html
val_errors = rep(NA,37)
# Iterationen über jede Größe i
for(i in 1:37){
# Extrahieren des Vektors der Prädiktoren im Best-Fit-Modell für i-Prädiktoren
coefi = coef(best_subset_WG3, id = i)
# Vorhersagen unter Verwendung der Matrixmultiplikation der Testmatrix und des Koeffizientenvektors erstellen
pred = test_m[,names(coefi)]%*%coefi
# Berechnung des MSE
val_errors[i] = mean((df_lm_test_WG2$Umsatz-pred)^2)
}
# Auffinden des Modells mit dem kleinsten Fehler
min = which.min(val_errors)
# Plotten des Fehlers für jede Modellgröße
plot(val_errors, type = 'b')
points(min, val_errors[min][1], col = "red", cex = 2, pch = 20)Es ist erkennbar, dass ein 21-Variablen-Modell, das durch den besten Teilmengenansatz erzeugt wird, den niedrigsten Test-MSE erzeugt. Auch ein 10- bzw. 12-Variablen-Modell scheinen vergleichweichsweise gut zu performen.
Wir können jetzt die beste Teilmengenauswahl für den gesamten Datensatz durchführen, um zum einen das 20-Variablen-Modell zu erhalten. Dieses Modell wird mit den 30-Variablen-Modellen nach Best subset selection verglichen.
Teilmengenauswahl für das 20-Variablen-Modell
Die 20 Variablen sind die folgenden:
- KielerWoche
- Temperatur
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cFebruar
- Monat_cJanuar
- Monat_cJuni
- Monat_cMärz
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Feiertag
- Ostern
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- JahreszeitHerbst
Die Variablen Wochentag_c, Monat und Jahreszeit müssen noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG3_20 <- df_lm_train_WG3 %>%
mutate(Montag=as.integer(df_lm_train_WG3$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG3$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG3$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG3$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG3$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG3$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG3$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG3$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG3$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG3$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG3$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG3$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG3$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG3$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG3$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG3$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG3$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG3$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG3$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG3$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG3$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG3$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG3$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG3_20 <- df_lm_test_WG3 %>%
mutate(Montag=as.integer(df_lm_test_WG3$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG3$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG3$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG3$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG3$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG3$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG3$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG3$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG3$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG3$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG3$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG3$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG3$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG3$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG3$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG3$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG3$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG3$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG3$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG2$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG3$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG3$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG3$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 20-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG3_20_train <- lm(Umsatz ~ KielerWoche + Temperatur + Freitag + Samstag + Sonntag + August + Dezember + Juli + Juni + Mai + November + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienNDS + SommerferienHE + Feiertag + Ostern_ext + ChristiHimmelfahrt_ext + Silvester_ext + Herbst, data = df_lm_train_WG3_20)
glance(lm_WG3_20_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.816 0.812 28.8 210. 0 23 -5059. 10167.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 41.8412802 0.8374625 31.1965855
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG3_20 <- df_lm_test_WG3_20 %>%
mutate(predicted = lm_WG3_20_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG3_20 <- df_lm_test_WG3_20 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG3_20 <-df_lm_test_WG3_20 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG3_20 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best20_WG3")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 9 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7 24.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6 24.7
## 3 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4 24.5
## 4 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4 24.5
## 5 346 130413. 377. 39.8 3.37 11.4 10.6 2708. 52.0 13.8
## 6 346 130413. 377. 39.8 3.45 11.4 10.6 2722. 52.2 13.8
## 7 346 130413. 377. 40.3 3.48 11.6 10.7 2768. 52.6 14.0
## 8 346 130413. 377. 39.9 3.52 11.5 10.6 2720. 52.2 13.8
## 9 346 59316. 171. 31.2 -8.4 17.3 18.2 1751. 41.8 24.4
## # ... with 1 more variable: Modell <chr>
Teilmengenauswahl für das 30-Variablen-Modell
Die 30 Variablen sind die folgenden:
- KielerWoche
- Temperatur
- Bewoelkung
- Wochentag_cFreitag
- Wochentag_cMonatg
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cAugust
- Monat_cFebruar
- Monat_cJanuar
- Monat_cJuli
- Monat_cJuni
- Monat_cMai
- Monat_cMärz
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- SommerferienHE
- Ostern
- Pfingsten
- TDE
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- Silvester_ext
- JahreszeitHerbst
- JahreszeitSommer
- JahreszeitWinter
Die Variablen Wochentag_c, Monat_c und Jahreszeit nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG3_30 <- df_lm_train_WG3 %>%
mutate(Montag=as.integer(df_lm_train_WG3$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG3$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG3$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG3$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG3$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG3$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG3$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG3$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG3$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG3$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG3$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG3$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG3$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG3$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG3$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG3$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG3$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG3$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG3$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG3$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG3$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG3$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG3$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG3_30 <- df_lm_test_WG3 %>%
mutate(Montag=as.integer(df_lm_test_WG3$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG3$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG3$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG3$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG3$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG3$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG3$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG3$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG3$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG3$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG3$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG3$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG3$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG3$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG3$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG3$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG3$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG3$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG3$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG2$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG3$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG3$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG3$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 30-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG3_30_train <- lm(Umsatz ~ KielerWoche + Bewoelkung + Temperatur + Freitag + Montag + Samstag + Sonntag + August + Februar + Januar + Juli + Juni + Mai + Maerz + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienNDS + SommerferienHE + Ostern + Pfingsten + TDE + Ostern_ext + ChristiHimmelfahrt_ext + Pfingsten_ext + Silvester_ext + Herbst + Sommer + Winter, data = df_lm_train_WG3_30)
glance(lm_WG3_30_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.832 0.827 27.6 170. 0 31 -5011. 10087.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 41.5002364 0.8412858 30.9411360
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG3_30 <- df_lm_test_WG3_30 %>%
mutate(predicted = lm_WG3_30_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG3_30 <- df_lm_test_WG3_30 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG3_30 <-df_lm_test_WG3_30 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG3_30 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best30_WG3")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 10 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6
## 3 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4
## 4 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4
## 5 346 130413. 377. 39.8 3.37 11.4 10.6 2708. 52.0
## 6 346 130413. 377. 39.8 3.45 11.4 10.6 2722. 52.2
## 7 346 130413. 377. 40.3 3.48 11.6 10.7 2768. 52.6
## 8 346 130413. 377. 39.9 3.52 11.5 10.6 2720. 52.2
## 9 346 59316. 171. 31.2 -8.4 17.3 18.2 1751. 41.8
## 10 346 59316. 171. 30.9 -8.38 17.4 18.0 1722. 41.5
## # ... with 2 more variables: rRMSE <dbl>, Modell <chr>
Auch bei der Warengruppe 3 gibt es hnur marginale Unterschiede zwischen dem 20- und dem 30-Variablen-Modell. Letzteres performt ein wenig besser, aht aber den Nachteil, dass es 50% mehr Prädikatoren enthält. Es ist die Frage, ob sich das Aufblähen des Modells für eine solch marginale Verbesserung lohnt. An dieser Stelle wird das bisherige Vorgehen weiterverfolgt und gemessen an den Gütekriterien das 30-Variablen-Modell ausgewählt.
Die 30 Variablen, die am besten geeignet sind um Prognosen für die Umsätze der Warengruppe 3 vorzunehmen sind:
- KielerWoche
- Temperatur
- Bewoelkung
- Wochentage:
- Freitag
- Montag
- Samstag
- Sonntag
- Monate:
- August
- Februar
- Januar
- Juli
- Juni
- Mai
- März
- Oktober
- September
- Sommerferien
- SH
- NRW
- NDS
- HE
- Ostern
- Pfingsten
- TDE
- Ostern_ext
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- Silvester_ext
- Jahreszeiten:
- Herbst
- Sommer
- Winter
6.3.4 Warengruppe 4
Erstellung von Trainings- und Testdatensätzen für Warengruppe 5
df_lm_train_WG4 <- df_lm_train %>% filter(Warengruppe == "4")
df_lm_train_WG4 <- na.omit(df_lm_train_WG4)
df_lm_train_WG4 <- df_lm_train_WG4 %>% dplyr::select(-Warengruppe)
df_lm_test_WG4 <- df_lm_test %>% filter(Warengruppe == "4")
df_lm_test_WG4 <- na.omit(df_lm_test_WG4)
df_lm_test_WG4 <- df_lm_test_WG4 %>% dplyr::select(-Warengruppe)Auswahl der am besten geeigneten Variablen Was die Vorgehensweise und die enstsprechenden Erläuterungen anbelangt, siehe 6.3.1.
Beste Teilmengenauswahl (“Best subset selection”)
Die regsubsets-Funktion gibt ein Listenobjekt mit vielen Informationen zurück. Zunächst kann der Befehl summary verwendet, um den besten Satz von Variablen für jede Modellgröße zu ermitteln.
## Subset selection object
## Call: regsubsets.formula(Umsatz ~ ., df_lm_train_WG4, nvmax = 37)
## 37 Variables (and intercept)
## Forced in Forced out
## KielerWoche FALSE FALSE
## Bewoelkung FALSE FALSE
## Temperatur FALSE FALSE
## Windgeschwindigkeit FALSE FALSE
## Wochentag_cDonnerstag FALSE FALSE
## Wochentag_cFreitag FALSE FALSE
## Wochentag_cMittwoch FALSE FALSE
## Wochentag_cMontag FALSE FALSE
## Wochentag_cSamstag FALSE FALSE
## Wochentag_cSonntag FALSE FALSE
## Monat_cAugust FALSE FALSE
## Monat_cDezember FALSE FALSE
## Monat_cFebruar FALSE FALSE
## Monat_cJanuar FALSE FALSE
## Monat_cJuli FALSE FALSE
## Monat_cJuni FALSE FALSE
## Monat_cMai FALSE FALSE
## Monat_cMärz FALSE FALSE
## Monat_cNovember FALSE FALSE
## Monat_cOktober FALSE FALSE
## Monat_cSeptember FALSE FALSE
## SommerferienSH FALSE FALSE
## SommerferienNRW FALSE FALSE
## SommerferienNDS FALSE FALSE
## SommerferienHE FALSE FALSE
## Feiertag FALSE FALSE
## Ostern FALSE FALSE
## ChristiHimmelfahrt FALSE FALSE
## Pfingsten FALSE FALSE
## TDE FALSE FALSE
## Ostern_ext FALSE FALSE
## ChristiHimmelfahrt_ext FALSE FALSE
## Pfingsten_ext FALSE FALSE
## Silvester_ext FALSE FALSE
## JahreszeitHerbst FALSE FALSE
## JahreszeitSommer FALSE FALSE
## JahreszeitWinter FALSE FALSE
## 1 subsets of each size up to 37
## Selection Algorithm: exhaustive
## KielerWoche Bewoelkung Temperatur Windgeschwindigkeit
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " " " " "
## 8 ( 1 ) " " " " " " " "
## 9 ( 1 ) " " " " " " " "
## 10 ( 1 ) " " " " " " " "
## 11 ( 1 ) " " " " " " " "
## 12 ( 1 ) " " " " " " " "
## 13 ( 1 ) " " " " " " " "
## 14 ( 1 ) " " " " " " " "
## 15 ( 1 ) " " " " " " " "
## 16 ( 1 ) " " " " " " " "
## 17 ( 1 ) " " " " " " " "
## 18 ( 1 ) " " " " " " " "
## 19 ( 1 ) " " " " "*" " "
## 20 ( 1 ) " " " " "*" " "
## 21 ( 1 ) " " " " "*" " "
## 22 ( 1 ) " " " " "*" " "
## 23 ( 1 ) " " " " "*" " "
## 24 ( 1 ) " " " " "*" " "
## 25 ( 1 ) " " " " "*" " "
## 26 ( 1 ) " " "*" "*" " "
## 27 ( 1 ) " " "*" "*" "*"
## 28 ( 1 ) " " "*" "*" "*"
## 29 ( 1 ) " " "*" "*" "*"
## 30 ( 1 ) " " "*" "*" "*"
## 31 ( 1 ) " " "*" "*" "*"
## 32 ( 1 ) " " "*" "*" "*"
## 33 ( 1 ) " " "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## Wochentag_cDonnerstag Wochentag_cFreitag Wochentag_cMittwoch
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " " "
## 9 ( 1 ) " " " " " "
## 10 ( 1 ) " " " " " "
## 11 ( 1 ) " " " " " "
## 12 ( 1 ) " " " " " "
## 13 ( 1 ) "*" " " " "
## 14 ( 1 ) "*" " " " "
## 15 ( 1 ) " " "*" " "
## 16 ( 1 ) "*" " " "*"
## 17 ( 1 ) " " "*" " "
## 18 ( 1 ) "*" " " "*"
## 19 ( 1 ) "*" " " "*"
## 20 ( 1 ) " " "*" " "
## 21 ( 1 ) "*" "*" " "
## 22 ( 1 ) " " "*" " "
## 23 ( 1 ) "*" "*" " "
## 24 ( 1 ) "*" "*" " "
## 25 ( 1 ) "*" "*" " "
## 26 ( 1 ) "*" "*" " "
## 27 ( 1 ) "*" "*" " "
## 28 ( 1 ) "*" "*" "*"
## 29 ( 1 ) "*" "*" "*"
## 30 ( 1 ) "*" "*" "*"
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
## Wochentag_cMontag Wochentag_cSamstag Wochentag_cSonntag
## 1 ( 1 ) " " " " "*"
## 2 ( 1 ) " " " " "*"
## 3 ( 1 ) " " " " "*"
## 4 ( 1 ) " " " " "*"
## 5 ( 1 ) " " "*" "*"
## 6 ( 1 ) " " "*" "*"
## 7 ( 1 ) " " "*" "*"
## 8 ( 1 ) " " "*" "*"
## 9 ( 1 ) " " "*" "*"
## 10 ( 1 ) " " "*" "*"
## 11 ( 1 ) " " "*" "*"
## 12 ( 1 ) " " "*" "*"
## 13 ( 1 ) " " "*" "*"
## 14 ( 1 ) " " "*" "*"
## 15 ( 1 ) "*" "*" "*"
## 16 ( 1 ) " " "*" "*"
## 17 ( 1 ) "*" "*" "*"
## 18 ( 1 ) " " "*" "*"
## 19 ( 1 ) " " "*" "*"
## 20 ( 1 ) "*" "*" "*"
## 21 ( 1 ) "*" "*" "*"
## 22 ( 1 ) "*" "*" "*"
## 23 ( 1 ) "*" "*" "*"
## 24 ( 1 ) "*" "*" "*"
## 25 ( 1 ) "*" "*" "*"
## 26 ( 1 ) "*" "*" "*"
## 27 ( 1 ) "*" "*" "*"
## 28 ( 1 ) "*" "*" "*"
## 29 ( 1 ) "*" "*" "*"
## 30 ( 1 ) "*" "*" "*"
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
## Monat_cAugust Monat_cDezember Monat_cFebruar Monat_cJanuar
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " "*" " "
## 3 ( 1 ) " " " " "*" " "
## 4 ( 1 ) "*" " " "*" " "
## 5 ( 1 ) "*" " " "*" " "
## 6 ( 1 ) "*" " " "*" " "
## 7 ( 1 ) "*" " " "*" " "
## 8 ( 1 ) " " " " "*" " "
## 9 ( 1 ) " " " " "*" " "
## 10 ( 1 ) "*" " " "*" " "
## 11 ( 1 ) " " " " "*" " "
## 12 ( 1 ) " " " " "*" " "
## 13 ( 1 ) " " " " "*" " "
## 14 ( 1 ) " " " " "*" " "
## 15 ( 1 ) " " " " "*" " "
## 16 ( 1 ) " " " " "*" " "
## 17 ( 1 ) " " " " "*" " "
## 18 ( 1 ) " " "*" "*" " "
## 19 ( 1 ) " " "*" "*" " "
## 20 ( 1 ) " " "*" "*" " "
## 21 ( 1 ) " " "*" "*" " "
## 22 ( 1 ) " " "*" "*" "*"
## 23 ( 1 ) " " "*" "*" "*"
## 24 ( 1 ) " " "*" "*" "*"
## 25 ( 1 ) " " "*" "*" "*"
## 26 ( 1 ) " " "*" "*" "*"
## 27 ( 1 ) " " "*" "*" "*"
## 28 ( 1 ) " " "*" "*" "*"
## 29 ( 1 ) " " "*" "*" "*"
## 30 ( 1 ) " " "*" "*" "*"
## 31 ( 1 ) " " "*" "*" "*"
## 32 ( 1 ) " " "*" "*" "*"
## 33 ( 1 ) " " "*" "*" "*"
## 34 ( 1 ) " " "*" "*" "*"
## 35 ( 1 ) " " "*" "*" "*"
## 36 ( 1 ) " " "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## Monat_cJuli Monat_cJuni Monat_cMai Monat_cMärz Monat_cNovember
## 1 ( 1 ) " " " " " " " " " "
## 2 ( 1 ) " " " " " " " " " "
## 3 ( 1 ) " " " " " " " " " "
## 4 ( 1 ) " " " " " " " " " "
## 5 ( 1 ) " " " " " " " " " "
## 6 ( 1 ) " " " " " " " " " "
## 7 ( 1 ) " " " " " " " " " "
## 8 ( 1 ) "*" "*" " " " " " "
## 9 ( 1 ) "*" "*" " " " " " "
## 10 ( 1 ) " " " " " " " " " "
## 11 ( 1 ) "*" "*" " " " " " "
## 12 ( 1 ) "*" "*" " " " " " "
## 13 ( 1 ) "*" "*" " " " " " "
## 14 ( 1 ) "*" "*" " " " " " "
## 15 ( 1 ) "*" "*" " " " " " "
## 16 ( 1 ) "*" "*" " " " " " "
## 17 ( 1 ) "*" "*" " " " " " "
## 18 ( 1 ) "*" "*" " " " " "*"
## 19 ( 1 ) "*" "*" " " " " "*"
## 20 ( 1 ) "*" "*" " " " " "*"
## 21 ( 1 ) "*" "*" " " " " "*"
## 22 ( 1 ) "*" "*" " " " " "*"
## 23 ( 1 ) "*" "*" " " " " "*"
## 24 ( 1 ) "*" "*" " " " " "*"
## 25 ( 1 ) "*" "*" " " " " "*"
## 26 ( 1 ) "*" "*" " " " " "*"
## 27 ( 1 ) "*" "*" " " " " "*"
## 28 ( 1 ) "*" "*" " " " " "*"
## 29 ( 1 ) "*" "*" "*" " " "*"
## 30 ( 1 ) "*" "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*" "*"
## Monat_cOktober Monat_cSeptember SommerferienSH SommerferienNRW
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " "*" " " " "
## 7 ( 1 ) " " "*" " " " "
## 8 ( 1 ) " " " " " " " "
## 9 ( 1 ) " " " " " " " "
## 10 ( 1 ) " " "*" " " " "
## 11 ( 1 ) " " " " " " " "
## 12 ( 1 ) " " " " "*" " "
## 13 ( 1 ) " " " " "*" " "
## 14 ( 1 ) " " " " "*" " "
## 15 ( 1 ) " " " " "*" " "
## 16 ( 1 ) " " " " "*" " "
## 17 ( 1 ) " " " " "*" " "
## 18 ( 1 ) " " " " "*" " "
## 19 ( 1 ) " " " " "*" " "
## 20 ( 1 ) " " " " "*" " "
## 21 ( 1 ) " " " " "*" " "
## 22 ( 1 ) " " " " "*" " "
## 23 ( 1 ) " " " " "*" " "
## 24 ( 1 ) "*" " " "*" " "
## 25 ( 1 ) "*" " " "*" " "
## 26 ( 1 ) "*" " " "*" " "
## 27 ( 1 ) "*" " " "*" " "
## 28 ( 1 ) "*" " " "*" " "
## 29 ( 1 ) "*" " " "*" " "
## 30 ( 1 ) "*" " " "*" " "
## 31 ( 1 ) "*" " " "*" " "
## 32 ( 1 ) "*" " " "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## SommerferienNDS SommerferienHE Feiertag Ostern
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " "*" " "
## 4 ( 1 ) " " " " "*" " "
## 5 ( 1 ) " " " " "*" " "
## 6 ( 1 ) " " " " "*" " "
## 7 ( 1 ) " " " " "*" " "
## 8 ( 1 ) " " " " "*" " "
## 9 ( 1 ) " " " " " " " "
## 10 ( 1 ) " " " " "*" "*"
## 11 ( 1 ) " " " " "*" "*"
## 12 ( 1 ) " " " " "*" "*"
## 13 ( 1 ) " " " " "*" "*"
## 14 ( 1 ) " " " " "*" "*"
## 15 ( 1 ) " " " " "*" "*"
## 16 ( 1 ) " " " " "*" "*"
## 17 ( 1 ) " " " " "*" "*"
## 18 ( 1 ) " " " " "*" "*"
## 19 ( 1 ) " " " " "*" "*"
## 20 ( 1 ) " " " " "*" "*"
## 21 ( 1 ) " " " " "*" "*"
## 22 ( 1 ) " " " " "*" "*"
## 23 ( 1 ) " " " " "*" "*"
## 24 ( 1 ) " " " " "*" "*"
## 25 ( 1 ) " " " " "*" "*"
## 26 ( 1 ) " " " " "*" "*"
## 27 ( 1 ) " " " " "*" "*"
## 28 ( 1 ) " " " " "*" "*"
## 29 ( 1 ) " " " " "*" "*"
## 30 ( 1 ) " " " " "*" "*"
## 31 ( 1 ) " " "*" "*" "*"
## 32 ( 1 ) " " "*" "*" "*"
## 33 ( 1 ) " " "*" "*" "*"
## 34 ( 1 ) " " "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## ChristiHimmelfahrt Pfingsten TDE Ostern_ext
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " " " " "
## 8 ( 1 ) " " " " " " " "
## 9 ( 1 ) "*" "*" "*" " "
## 10 ( 1 ) "*" "*" "*" " "
## 11 ( 1 ) "*" "*" "*" " "
## 12 ( 1 ) "*" "*" "*" " "
## 13 ( 1 ) "*" "*" "*" " "
## 14 ( 1 ) "*" "*" "*" " "
## 15 ( 1 ) "*" "*" "*" " "
## 16 ( 1 ) "*" "*" "*" " "
## 17 ( 1 ) "*" "*" "*" " "
## 18 ( 1 ) "*" "*" "*" " "
## 19 ( 1 ) "*" "*" "*" " "
## 20 ( 1 ) "*" "*" "*" " "
## 21 ( 1 ) "*" "*" "*" " "
## 22 ( 1 ) "*" "*" "*" " "
## 23 ( 1 ) "*" "*" "*" " "
## 24 ( 1 ) "*" "*" "*" " "
## 25 ( 1 ) "*" "*" "*" "*"
## 26 ( 1 ) "*" "*" "*" "*"
## 27 ( 1 ) "*" "*" "*" "*"
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " "*"
## 8 ( 1 ) " " " " "*"
## 9 ( 1 ) " " " " " "
## 10 ( 1 ) " " " " " "
## 11 ( 1 ) " " " " " "
## 12 ( 1 ) " " " " " "
## 13 ( 1 ) " " " " " "
## 14 ( 1 ) " " " " " "
## 15 ( 1 ) " " " " " "
## 16 ( 1 ) "*" " " " "
## 17 ( 1 ) "*" "*" " "
## 18 ( 1 ) "*" " " " "
## 19 ( 1 ) "*" " " " "
## 20 ( 1 ) "*" "*" " "
## 21 ( 1 ) "*" "*" " "
## 22 ( 1 ) "*" "*" " "
## 23 ( 1 ) "*" "*" " "
## 24 ( 1 ) "*" "*" " "
## 25 ( 1 ) "*" "*" " "
## 26 ( 1 ) "*" "*" " "
## 27 ( 1 ) "*" "*" " "
## 28 ( 1 ) "*" "*" " "
## 29 ( 1 ) "*" "*" " "
## 30 ( 1 ) "*" "*" " "
## 31 ( 1 ) "*" "*" " "
## 32 ( 1 ) "*" "*" " "
## 33 ( 1 ) "*" "*" " "
## 34 ( 1 ) "*" "*" " "
## 35 ( 1 ) "*" "*" " "
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
## JahreszeitHerbst JahreszeitSommer JahreszeitWinter
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " "*" " "
## 9 ( 1 ) " " "*" " "
## 10 ( 1 ) " " " " " "
## 11 ( 1 ) " " "*" " "
## 12 ( 1 ) " " "*" " "
## 13 ( 1 ) " " "*" " "
## 14 ( 1 ) "*" "*" " "
## 15 ( 1 ) "*" "*" " "
## 16 ( 1 ) "*" "*" " "
## 17 ( 1 ) "*" "*" " "
## 18 ( 1 ) "*" "*" " "
## 19 ( 1 ) "*" "*" " "
## 20 ( 1 ) "*" "*" " "
## 21 ( 1 ) "*" "*" " "
## 22 ( 1 ) "*" "*" "*"
## 23 ( 1 ) "*" "*" "*"
## 24 ( 1 ) "*" "*" "*"
## 25 ( 1 ) "*" "*" "*"
## 26 ( 1 ) "*" "*" "*"
## 27 ( 1 ) "*" "*" "*"
## 28 ( 1 ) "*" "*" "*"
## 29 ( 1 ) "*" "*" "*"
## 30 ( 1 ) "*" "*" "*"
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
Für ein Modell mit einer Variablen kann beobachtet werden, dass die Variable Wochentag_cSonntag ein Sternchen hat, was signalisiert, dass ein Regressionsmodell mit Umsatz ~ Wochentag_cSonntag das beste Einzelvariablenmodell ist. Das beste 2-Variablen-Modell ist Umsatz ~ Wochentag_cSonntag + Monat_cFebruar. Das beste 3-Variablen-Modell ist Umsatz ~ Wochentag_cSonntag + Monat_cFebruar + Feiertag. Und so weiter.
Schrittweise Auswahl (“Stepwise selection”)
Schrittweise vorwärts (Forward stepwise)
Die schrittweise Vorwärtsauswahl kann mit regsubsets durchgeführt werden, indem die method = "forward" gesetzt wird:
Schrittweise rückwärts (Backward stepwise)
Die schrittweise Vorwärtsauswahl kann mit regsubsets durchgeführt werden, indem die method = "backward" gesetzt wird:
Modellauswahl
Indirekte Schätzung des Testfehlers mit \(C_{p}\), \(AIC\), \(BIC\) und adjustiertem \(R^2\)
results <- summary(best_subset_WG4)
# Extrahieren und plotten der Ergebnisse
tibble(predictors = 1:37,
adj_R2 = results$adjr2,
Cp = results$cp,
BIC = results$bic) %>%
gather(statistic, value, -predictors) %>%
ggplot(aes(predictors, value, color = statistic)) +
geom_line(show.legend = F) +
geom_point(show.legend = F) +
facet_wrap(~ statistic, scales = "free")## [1] 20
## [1] 11
## [1] 14
Es ist erkennbar, dass die Ergebnisse leicht unterschiedliche Modelle identifizieren, die als die besten angesehen werden. Die ajustierte \(R^2\)-Statistik legt nahe, dass ein 20-Variablen-Modell bevorzugt wird, die \(BIC\)-Statistik schlägt ein 11-Variablenmodell vor und der \(C_{p}\) ein 14-Variablen-Modell vor.
Das Ergebnis wird verglichen mit der Auswahl nach forward und backward selection:
## [1] 18
## [1] 15
Wenn man das optimale \(C_{p}\) für vorwärts und rückwärts schrittweise bewertet, ist erkennbar, dass gemäß der Vorwärts-Methode ein 18-Variablen-Modell die \(C_{p}\)-Statistik minimiert. Die Rückwärtsmethode schlägt ein 15-Variablen-Modell vor.
Wenn wir diese Modelle bewerten, ergibt sich bzgl. der Zusammensetzung der Prädikatoren folgendes Bild:.
## (Intercept) Wochentag_cSamstag Wochentag_cSonntag
## 74.74631 10.82251 53.05171
## Monat_cFebruar Monat_cJuli Monat_cJuni
## 42.54486 -16.78346 -13.94296
## Feiertag Ostern ChristiHimmelfahrt
## -59.20842 85.71959 118.97211
## Pfingsten TDE JahreszeitSommer
## 117.38558 101.92794 11.79000
## (Intercept) Wochentag_cDonnerstag Wochentag_cSamstag
## 74.203835 -4.515529 9.918655
## Wochentag_cSonntag Monat_cFebruar Monat_cJuli
## 52.287664 43.960289 -14.855994
## Monat_cJuni SommerferienSH Feiertag
## -11.663708 6.951056 -57.831994
## Ostern ChristiHimmelfahrt Pfingsten
## 85.267661 122.653688 116.173897
## TDE JahreszeitHerbst JahreszeitSommer
## 98.098575 3.296699 9.311380
## (Intercept) Temperatur Wochentag_cFreitag
## 73.6246055 -0.2397414 5.1100427
## Wochentag_cMontag Wochentag_cSamstag Wochentag_cSonntag
## 3.7589249 12.2146160 54.8519519
## Monat_cDezember Monat_cFebruar Monat_cJuli
## -5.3086879 42.8280457 -14.6256190
## Monat_cJuni Monat_cNovember SommerferienSH
## -10.3440932 -6.5248038 7.4226525
## Feiertag Ostern ChristiHimmelfahrt
## -52.8038954 79.6430427 105.6638117
## Pfingsten TDE ChristiHimmelfahrt_ext
## 96.8512966 91.5348039 11.6375819
## Pfingsten_ext JahreszeitHerbst JahreszeitSommer
## 14.6446149 6.8375903 11.5166660
Die Auswahl gemäß forward und backward selection ergibt sich wie folgt:
## (Intercept) Temperatur Wochentag_cDonnerstag
## 77.4830876 -0.2960164 -5.1814174
## Wochentag_cMittwoch Wochentag_cSamstag Wochentag_cSonntag
## -3.5371804 8.6956545 51.2675353
## Monat_cAugust Monat_cFebruar Monat_cJuni
## 19.4669849 42.7128158 -5.6629781
## Monat_cOktober Monat_cSeptember Feiertag
## 6.3474783 12.6259097 -54.1769228
## Ostern ChristiHimmelfahrt Pfingsten
## 81.2954037 108.1507046 100.7715966
## TDE ChristiHimmelfahrt_ext Pfingsten_ext
## 92.7739082 12.6945291 11.1417616
## Silvester_ext
## -3.8738520
## (Intercept) Wochentag_cFreitag Wochentag_cMontag
## 71.576948 5.216883 3.676093
## Wochentag_cSamstag Wochentag_cSonntag Monat_cFebruar
## 12.587968 54.978079 43.894295
## Monat_cJuli Monat_cJuni SommerferienSH
## -15.119148 -11.754923 6.775400
## Feiertag Ostern ChristiHimmelfahrt
## -57.884972 84.764271 120.818023
## Pfingsten TDE JahreszeitHerbst
## 115.700912 98.765918 3.194085
## JahreszeitSommer
## 9.451641
Direkte Schätzung des Testfehlers
Nun wird der Fehler der Testdaten für das beste Modell jeder Modellgröße berechnet. Zuerst wird eine Modellmatrix aus den Testdaten erstellt. Die Funktion model.matrix wird in vielen Regressionspaketen zum Erstellen einer X-Matrix aus Daten verwendet.
Jetzt kann jede Modellgröße (d.h. 1 Variable, 2 Variablen,…, 20 Variablen) durchlaufen werden und die Koeffizienten für das beste Modell dieser Größe extrahiert werden. Diese Werte werden sodann in die entsprechenden Spalten der Testmodellmatrix multipliziert, um die Vorhersagen zu bilden. Dann werden die Test-MSE berechnet.
# Erstellen eines leeren Vektors, um diesen nachfolgend mit den Fehlerwerten zu füllen
validation_errors <- vector("double", length = 37)
for(i in 1:37) {
coef_x <- coef(best_subset_WG4, id = i) # extract coefficients for model size i
pred_x <- test_m[ , names(coef_x)] %*% coef_x # predict salary using matrix algebra
validation_errors[i] <- mean((df_lm_test_WG4$Umsatz - pred_x)^2) # compute test error btwn actual & predicted salary
}
as.matrix(validation_errors)## [,1]
## [1,] 525.7183
## [2,] 599.4985
## [3,] 610.9880
## [4,] 620.8920
## [5,] 616.1449
## [6,] 610.1408
## [7,] 603.5582
## [8,] 580.9132
## [9,] 602.3907
## [10,] 628.1246
## [11,] 607.1358
## [12,] 603.6362
## [13,] 604.4183
## [14,] 604.7203
## [15,] 604.3582
## [16,] 605.0185
## [17,] 608.0941
## [18,] 597.3093
## [19,] 590.5291
## [20,] 593.1788
## [21,] 593.5012
## [22,] 592.5746
## [23,] 592.8062
## [24,] 591.6309
## [25,] 592.5584
## [26,] 594.3739
## [27,] 594.7218
## [28,] 594.0891
## [29,] 592.2289
## [30,] 594.4524
## [31,] 594.9515
## [32,] 594.5469
## [33,] 594.1381
## [34,] 594.2219
## [35,] 594.2655
## [36,] 594.1626
## [37,] 594.1671
#############################
# Alternative: http://www.science.smith.edu/~jcrouser/SDS293/labs/lab9-r.html
val_errors = rep(NA, 37)
# Iterationen über jede Größe i
for(i in 1:37){
# Extrahieren des Vektors der Prädiktoren im Best-Fit-Modell für i-Prädiktoren
coefi = coef(best_subset_WG4, id = i)
# Vorhersagen unter Verwendung der Matrixmultiplikation der Testmatrix und des Koeffizientenvektors erstellen
pred = test_m[,names(coefi)]%*%coefi
# Berechnung des MSE
val_errors[i] = mean((df_lm_test_WG4$Umsatz-pred)^2)
}
# Auffinden des Modells mit dem kleinsten Fehler
min = which.min(val_errors)
# Plotten des Fehlers für jede Modellgröße
plot(val_errors, type = 'b')
points(min, val_errors[min][1], col = "red", cex = 2, pch = 20)Es ist erkennbar, dass das 1-Variablen-Modell, das durch den besten Teilmengenansatz erzeugt wird, den niedrigsten Test-MSE erzeugt.
Verglichen werden nachfolgend das 1-Variablen-Modell, die 11- und 20-Variablen-Modelle nach best subset selection und die beiden forward und backward-Modelle.
Teilmengenauswahl für das 1-Variablen-Modell
final_best_WG4_1 <- regsubsets(Umsatz ~ ., data = df_lm_train_WG4, nvmax = 37)
coef(final_best_WG4_1, 1)## (Intercept) Wochentag_cSonntag
## 81.13245 51.68479
Die Variable ist der Wochentag_cSonntag
Die Variable Wochentag_c muss noch dummyfiziert werden.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG4_1 <- df_lm_train_WG4 %>%
mutate(Montag=as.integer(df_lm_train_WG4$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG4$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG4$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG4$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG4$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG4$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG4$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG4$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG4$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG4$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG4$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG4$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG4$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG4$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG4$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG4$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG4$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG4$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG4$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG4$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG4$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG4$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG4$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG4_1 <- df_lm_test_WG4 %>%
mutate(Montag=as.integer(df_lm_test_WG4$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG4$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG4$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG4$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG4$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG4$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG4$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG4$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG4$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG4$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG4$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG4$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG4$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG4$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG4$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG4$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG4$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG4$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG4$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG4$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG4$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG4$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG4$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 1-Variablenmodell wird nun ein Regressionsmodell erstellt:
## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.270 0.269 30.0 386. 1.84e-73 2 -5045. 10095.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dieses einfache Regressionsmodell hat einen vergleichweise schlechten \(R^2\)-Wert. Am Ende ist es wahrscheinlich zu einfach.
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 22.9285469 0.1924832 17.6887745
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG4_1 <- df_lm_test_WG4_1 %>%
mutate(predicted = lm_WG4_1_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG4_1 <-df_lm_test_WG4_1 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG4_1 <- df_lm_test_WG4_1 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG4_1 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best1_WG4")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 11 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6
## 3 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4
## 4 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4
## 5 346 130413. 377. 39.8 3.37 11.4 10.6 2708. 52.0
## 6 346 130413. 377. 39.8 3.45 11.4 10.6 2722. 52.2
## 7 346 130413. 377. 40.3 3.48 11.6 10.7 2768. 52.6
## 8 346 130413. 377. 39.9 3.52 11.5 10.6 2720. 52.2
## 9 346 59316. 171. 31.2 -8.4 17.3 18.2 1751. 41.8
## 10 346 59316. 171. 30.9 -8.38 17.4 18.0 1722. 41.5
## 11 345 28354. 82.2 17.7 13.7 24.5 21.5 526. 22.9
## # ... with 2 more variables: rRMSE <dbl>, Modell <chr>
Teilmengenauswahl für das 11-Variablen-Modell
Die 11 Variablen sind die folgenden:
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cFebruar
- Monat_cJuli
- Monat_cJuni
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- JahreszeitSommer
Die Variablen Wochentag_c, Monat_c und Jahreszeit nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG4_11 <- df_lm_train_WG4 %>%
mutate(Montag=as.integer(df_lm_train_WG4$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG4$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG4$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG4$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG4$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG4$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG4$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG4$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG4$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG4$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG4$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG4$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG4$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG4$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG4$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG4$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG4$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG4$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG4$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG4$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG4$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG4$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG4$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG4_11 <- df_lm_test_WG4 %>%
mutate(Montag=as.integer(df_lm_test_WG4$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG4$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG4$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG4$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG4$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG4$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG4$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG4$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG4$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG4$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG4$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG4$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG4$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG4$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG4$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG4$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG4$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG4$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG4$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG4$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG4$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG4$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG4$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 11-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG4_11_train <- lm(Umsatz ~ Samstag + Sonntag + Februar + Juli + Juni + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + Sommer, data = df_lm_train_WG4_11)
glance(lm_WG4_11_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.443 0.437 26.3 74.9 1.78e-123 12 -4903. 9831.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 24.6401267 0.2090212 18.2669810
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG4_11 <- df_lm_test_WG4_11 %>%
mutate(predicted = lm_WG4_11_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG4_11 <-df_lm_test_WG4_11 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG4_11 <- df_lm_test_WG4_11 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG4_11 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best11_WG4")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 12 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6
## 3 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4
## 4 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4
## 5 346 130413. 377. 39.8 3.37 11.4 10.6 2708. 52.0
## 6 346 130413. 377. 39.8 3.45 11.4 10.6 2722. 52.2
## 7 346 130413. 377. 40.3 3.48 11.6 10.7 2768. 52.6
## 8 346 130413. 377. 39.9 3.52 11.5 10.6 2720. 52.2
## 9 346 59316. 171. 31.2 -8.4 17.3 18.2 1751. 41.8
## 10 346 59316. 171. 30.9 -8.38 17.4 18.0 1722. 41.5
## 11 345 28354. 82.2 17.7 13.7 24.5 21.5 526. 22.9
## 12 345 28354. 82.2 18.3 12.0 24.2 22.2 607. 24.6
## # ... with 2 more variables: rRMSE <dbl>, Modell <chr>
Teilmengenauswahl für das 20-Variablen-Modell nach best subset selection
Die 20 Variablen sind die folgenden:
- Temperatur
- Wochentag_cFreitag
- Wochentag_cMontag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cDezember
- Monat_cFebruar
- Monat_cJuli
- Monat_cJuni
- Monat_cNovember
- SommerferienSH
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- JahreszeitHerbst
- JahreszeitSommer
Die Variablen Wochentag_c, Monat_c und Jahreszeit nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG4_20 <- df_lm_train_WG4 %>%
mutate(Montag=as.integer(df_lm_train_WG4$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG4$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG4$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG4$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG4$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG4$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG4$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG4$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG4$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG4$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG4$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG4$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG4$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG4$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG4$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG4$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG4$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG4$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG4$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG4$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG4$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG4$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG4$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG4_20 <- df_lm_test_WG4 %>%
mutate(Montag=as.integer(df_lm_test_WG4$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG4$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG4$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG4$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG4$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG4$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG4$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG4$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG4$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG4$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG4$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG4$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG4$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG4$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG4$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG4$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG4$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG4$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG4$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG4$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG4$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG4$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG4$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 20-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG4_20_train <- lm(Umsatz ~ Temperatur + Freitag + Montag + Samstag + Sonntag + Dezember + Februar + Juli + Juni + November + SommerferienSH + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + ChristiHimmelfahrt_ext + Pfingsten_ext + Herbst + Sommer, data = df_lm_train_WG4_20)
glance(lm_WG4_20_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.453 0.443 26.2 42.6 1.52e-119 21 -4893. 9830.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 24.3552623 0.2254455 18.1367153
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG4_20 <- df_lm_test_WG4_20 %>%
mutate(predicted = lm_WG4_20_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG4_20 <-df_lm_test_WG4_20 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG4_20 <- df_lm_test_WG4_20 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG4_20 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best20_WG4")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 13 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6
## 3 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4
## 4 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4
## 5 346 130413. 377. 39.8 3.37 11.4 10.6 2708. 52.0
## 6 346 130413. 377. 39.8 3.45 11.4 10.6 2722. 52.2
## 7 346 130413. 377. 40.3 3.48 11.6 10.7 2768. 52.6
## 8 346 130413. 377. 39.9 3.52 11.5 10.6 2720. 52.2
## 9 346 59316. 171. 31.2 -8.4 17.3 18.2 1751. 41.8
## 10 346 59316. 171. 30.9 -8.38 17.4 18.0 1722. 41.5
## 11 345 28354. 82.2 17.7 13.7 24.5 21.5 526. 22.9
## 12 345 28354. 82.2 18.3 12.0 24.2 22.2 607. 24.6
## 13 345 28354. 82.2 18.1 11.6 23.8 22.1 593. 24.4
## # ... with 2 more variables: rRMSE <dbl>, Modell <chr>
Teilmengenauswahl für das 18-Variablen-Modell gemäß forward selection
Die 18 Variablen sind die folgenden:
- Temperatur
- Wochentag_cDonnerstag
- Wochentag_cMittwoch
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cAugust
- Monat_cFebruar
- Monat_cJuni
- Monat_cOktober
- Monat_cSeptember
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- ChristiHimmelfahrt_ext
- Pfingsten_ext
- Silvester_ext
Die VariablenWochentag_c,Monat_cundJahreszeitnun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte VariableWochentag_c` entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG4_18 <- df_lm_train_WG4 %>%
mutate(Montag=as.integer(df_lm_train_WG4$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG4$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG4$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG4$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG4$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG4$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG4$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG4$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG4$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG4$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG4$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG4$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG4$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG4$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG4$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG4$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG4$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG4$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG4$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG4$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG4$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG4$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG4$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG4_18 <- df_lm_test_WG4 %>%
mutate(Montag=as.integer(df_lm_test_WG4$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG4$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG4$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG4$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG4$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG4$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG4$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG4$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG4$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG4$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG4$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG4$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG4$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG4$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG4$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG4$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG4$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG4$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG4$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG4$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG4$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG4$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG4$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 18-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG4_18_train <- lm(Umsatz ~ Temperatur + Donnerstag + Mittwoch + Samstag + Sonntag + August + Februar + Juni + Oktober + September + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + ChristiHimmelfahrt_ext + Pfingsten_ext + Silvester_ext, data = df_lm_train_WG4_18)
glance(lm_WG4_18_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.451 0.441 26.2 46.9 3.98e-120 19 -4896. 9831.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 24.4829122 0.2245706 18.2475726
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG4_18 <- df_lm_test_WG4_18 %>%
mutate(predicted = lm_WG4_18_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG4_18 <-df_lm_test_WG4_18 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG4_18 <- df_lm_test_WG4_18 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG4_18 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best18_WG4")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 14 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6
## 3 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4
## 4 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4
## 5 346 130413. 377. 39.8 3.37 11.4 10.6 2708. 52.0
## 6 346 130413. 377. 39.8 3.45 11.4 10.6 2722. 52.2
## 7 346 130413. 377. 40.3 3.48 11.6 10.7 2768. 52.6
## 8 346 130413. 377. 39.9 3.52 11.5 10.6 2720. 52.2
## 9 346 59316. 171. 31.2 -8.4 17.3 18.2 1751. 41.8
## 10 346 59316. 171. 30.9 -8.38 17.4 18.0 1722. 41.5
## 11 345 28354. 82.2 17.7 13.7 24.5 21.5 526. 22.9
## 12 345 28354. 82.2 18.3 12.0 24.2 22.2 607. 24.6
## 13 345 28354. 82.2 18.1 11.6 23.8 22.1 593. 24.4
## 14 345 28354. 82.2 18.2 11.5 23.9 22.2 599. 24.5
## # ... with 2 more variables: rRMSE <dbl>, Modell <chr>
Teilmengenauswahl für das 15-Variablen-Modell gemäß backward selection
Die 15 Variablen sind die folgenden:
- Wochentag_cFreitag
- Wochentag_cMontag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cFebruar
- Monat_cJuli
- Monat_cJuni
- SommerferienSH
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- JahreszeitHerbst
- JahreszeitSommer
Die Variablen Wochentag_c, Monat_c und Jahreszeit nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG4_15 <- df_lm_train_WG4 %>%
mutate(Montag=as.integer(df_lm_train_WG4$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG4$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG4$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG4$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG4$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG4$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG4$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG4$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG4$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG4$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG4$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG4$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG4$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG4$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG4$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG4$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG4$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG4$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG4$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG4$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG4$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG4$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG4$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG4_15 <- df_lm_test_WG4 %>%
mutate(Montag=as.integer(df_lm_test_WG4$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG4$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG4$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG4$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG4$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG4$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG4$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG4$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG4$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG4$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG4$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG4$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG4$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG4$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG4$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG4$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG4$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG4$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG4$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG4$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG4$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG4$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG4$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 15-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG4_15_train <- lm(Umsatz ~ Freitag + Montag + Samstag + Sonntag + Februar + Juli + Juni + SommerferienSH + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + Herbst + Sommer, data = df_lm_train_WG4_15)
glance(lm_WG4_15_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.450 0.442 26.2 56.1 2.77e-122 16 -4897. 9827.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 24.583698 0.212243 18.357862
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG4_15 <- df_lm_test_WG4_15 %>%
mutate(predicted = lm_WG4_15_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG4_15 <-df_lm_test_WG4_15 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG4_15 <- df_lm_test_WG4_15 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG4_15 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best15_WG4")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 15 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6
## 3 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4
## 4 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4
## 5 346 130413. 377. 39.8 3.37 11.4 10.6 2708. 52.0
## 6 346 130413. 377. 39.8 3.45 11.4 10.6 2722. 52.2
## 7 346 130413. 377. 40.3 3.48 11.6 10.7 2768. 52.6
## 8 346 130413. 377. 39.9 3.52 11.5 10.6 2720. 52.2
## 9 346 59316. 171. 31.2 -8.4 17.3 18.2 1751. 41.8
## 10 346 59316. 171. 30.9 -8.38 17.4 18.0 1722. 41.5
## 11 345 28354. 82.2 17.7 13.7 24.5 21.5 526. 22.9
## 12 345 28354. 82.2 18.3 12.0 24.2 22.2 607. 24.6
## 13 345 28354. 82.2 18.1 11.6 23.8 22.1 593. 24.4
## 14 345 28354. 82.2 18.2 11.5 23.9 22.2 599. 24.5
## 15 345 28354. 82.2 18.4 12.1 24.2 22.3 604. 24.6
## # ... with 2 more variables: rRMSE <dbl>, Modell <chr>
Auch bei Warengruppe 4 gibt es nur sehr marginale unterschiede zwischen den einzelnen modellen. Selbst das 1-Variablen-Modell performt vergleichsweise gut. Der Sonntag scheint somit der ausschlaggebende Prädiktor für den Umsatz in der Warengruppe 4 zu sein. Das 18- und das 20-Variablen-Modell performen nahezu identisch. Da eine eindeutige Entscheidung zwischen dem 1-Variablen-Modell und dem 20-Variablen-Modell nicht möglich ist, wird an dieser Stelle das sehr schlanke Modell bevorzugt.
6.3.5 Warengruppe 5
Erstellung von Trainings- und Testdatensätzen für Warengruppe 5
df_lm_train_WG5 <- df_lm_train %>% filter(Warengruppe == "5")
df_lm_train_WG5 <- na.omit(df_lm_train_WG5)
df_lm_train_WG5 <- df_lm_train_WG5 %>% dplyr::select(-Warengruppe)
df_lm_test_WG5 <- df_lm_test %>% filter(Warengruppe == "5")
df_lm_test_WG5 <- na.omit(df_lm_test_WG5)
df_lm_test_WG5 <- df_lm_test_WG5 %>% dplyr::select(-Warengruppe)Auswahl der am besten geeigneten Variablen Was die Vorgehensweise und die enstsprechenden Erläuterungen anbelangt, siehe 6.3.1.
Beste Teilmengenauswahl (“Best subset selection”)
Die regsubsets-Funktion gibt ein Listenobjekt mit vielen Informationen zurück. Zunächst kann der Befehl summary verwendet, um den besten Satz von Variablen für jede Modellgröße zu ermitteln.
## Subset selection object
## Call: regsubsets.formula(Umsatz ~ ., df_lm_train_WG5, nvmax = 37)
## 37 Variables (and intercept)
## Forced in Forced out
## KielerWoche FALSE FALSE
## Bewoelkung FALSE FALSE
## Temperatur FALSE FALSE
## Windgeschwindigkeit FALSE FALSE
## Wochentag_cDonnerstag FALSE FALSE
## Wochentag_cFreitag FALSE FALSE
## Wochentag_cMittwoch FALSE FALSE
## Wochentag_cMontag FALSE FALSE
## Wochentag_cSamstag FALSE FALSE
## Wochentag_cSonntag FALSE FALSE
## Monat_cAugust FALSE FALSE
## Monat_cDezember FALSE FALSE
## Monat_cFebruar FALSE FALSE
## Monat_cJanuar FALSE FALSE
## Monat_cJuli FALSE FALSE
## Monat_cJuni FALSE FALSE
## Monat_cMai FALSE FALSE
## Monat_cMärz FALSE FALSE
## Monat_cNovember FALSE FALSE
## Monat_cOktober FALSE FALSE
## Monat_cSeptember FALSE FALSE
## SommerferienSH FALSE FALSE
## SommerferienNRW FALSE FALSE
## SommerferienNDS FALSE FALSE
## SommerferienHE FALSE FALSE
## Feiertag FALSE FALSE
## Ostern FALSE FALSE
## ChristiHimmelfahrt FALSE FALSE
## Pfingsten FALSE FALSE
## TDE FALSE FALSE
## Ostern_ext FALSE FALSE
## ChristiHimmelfahrt_ext FALSE FALSE
## Pfingsten_ext FALSE FALSE
## Silvester_ext FALSE FALSE
## JahreszeitHerbst FALSE FALSE
## JahreszeitSommer FALSE FALSE
## JahreszeitWinter FALSE FALSE
## 1 subsets of each size up to 37
## Selection Algorithm: exhaustive
## KielerWoche Bewoelkung Temperatur Windgeschwindigkeit
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " " " " "
## 8 ( 1 ) " " " " " " " "
## 9 ( 1 ) " " " " " " " "
## 10 ( 1 ) " " " " " " " "
## 11 ( 1 ) " " " " " " " "
## 12 ( 1 ) " " " " " " " "
## 13 ( 1 ) " " " " " " " "
## 14 ( 1 ) " " " " " " " "
## 15 ( 1 ) " " " " " " " "
## 16 ( 1 ) " " " " " " " "
## 17 ( 1 ) " " " " " " " "
## 18 ( 1 ) " " " " "*" " "
## 19 ( 1 ) " " " " "*" " "
## 20 ( 1 ) " " " " "*" " "
## 21 ( 1 ) " " " " "*" " "
## 22 ( 1 ) " " " " "*" " "
## 23 ( 1 ) " " " " "*" " "
## 24 ( 1 ) " " " " "*" " "
## 25 ( 1 ) " " "*" "*" " "
## 26 ( 1 ) " " "*" "*" " "
## 27 ( 1 ) "*" "*" "*" " "
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## Wochentag_cDonnerstag Wochentag_cFreitag Wochentag_cMittwoch
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " " " " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " " "
## 9 ( 1 ) " " " " " "
## 10 ( 1 ) " " " " " "
## 11 ( 1 ) " " " " " "
## 12 ( 1 ) " " " " " "
## 13 ( 1 ) " " " " " "
## 14 ( 1 ) " " " " " "
## 15 ( 1 ) " " "*" " "
## 16 ( 1 ) " " "*" " "
## 17 ( 1 ) " " "*" " "
## 18 ( 1 ) " " "*" " "
## 19 ( 1 ) " " "*" " "
## 20 ( 1 ) " " "*" " "
## 21 ( 1 ) " " "*" " "
## 22 ( 1 ) " " "*" " "
## 23 ( 1 ) " " "*" " "
## 24 ( 1 ) " " "*" " "
## 25 ( 1 ) " " "*" " "
## 26 ( 1 ) " " "*" " "
## 27 ( 1 ) " " "*" " "
## 28 ( 1 ) " " "*" " "
## 29 ( 1 ) " " "*" " "
## 30 ( 1 ) " " "*" " "
## 31 ( 1 ) " " "*" " "
## 32 ( 1 ) " " "*" " "
## 33 ( 1 ) " " "*" " "
## 34 ( 1 ) " " "*" " "
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
## Wochentag_cMontag Wochentag_cSamstag Wochentag_cSonntag
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " " " " "
## 3 ( 1 ) " " " " " "
## 4 ( 1 ) " " "*" " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " "*" " "
## 8 ( 1 ) " " "*" "*"
## 9 ( 1 ) " " "*" "*"
## 10 ( 1 ) " " "*" "*"
## 11 ( 1 ) " " "*" "*"
## 12 ( 1 ) " " "*" "*"
## 13 ( 1 ) " " "*" "*"
## 14 ( 1 ) " " "*" "*"
## 15 ( 1 ) " " "*" "*"
## 16 ( 1 ) "*" "*" "*"
## 17 ( 1 ) "*" "*" "*"
## 18 ( 1 ) " " "*" "*"
## 19 ( 1 ) "*" "*" "*"
## 20 ( 1 ) "*" "*" "*"
## 21 ( 1 ) " " "*" "*"
## 22 ( 1 ) " " "*" "*"
## 23 ( 1 ) "*" "*" "*"
## 24 ( 1 ) "*" "*" "*"
## 25 ( 1 ) "*" "*" "*"
## 26 ( 1 ) "*" "*" "*"
## 27 ( 1 ) "*" "*" "*"
## 28 ( 1 ) "*" "*" "*"
## 29 ( 1 ) "*" "*" "*"
## 30 ( 1 ) "*" "*" "*"
## 31 ( 1 ) "*" "*" "*"
## 32 ( 1 ) "*" "*" "*"
## 33 ( 1 ) "*" "*" "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" "*" "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
## Monat_cAugust Monat_cDezember Monat_cFebruar Monat_cJanuar
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " " " " "
## 8 ( 1 ) " " " " " " " "
## 9 ( 1 ) " " " " " " " "
## 10 ( 1 ) " " "*" " " " "
## 11 ( 1 ) " " "*" " " " "
## 12 ( 1 ) " " "*" " " " "
## 13 ( 1 ) " " "*" " " " "
## 14 ( 1 ) " " "*" "*" " "
## 15 ( 1 ) " " "*" "*" " "
## 16 ( 1 ) " " "*" "*" " "
## 17 ( 1 ) " " "*" "*" " "
## 18 ( 1 ) " " "*" "*" " "
## 19 ( 1 ) " " "*" "*" " "
## 20 ( 1 ) " " "*" "*" " "
## 21 ( 1 ) "*" "*" "*" " "
## 22 ( 1 ) "*" "*" "*" " "
## 23 ( 1 ) "*" "*" "*" " "
## 24 ( 1 ) "*" "*" "*" " "
## 25 ( 1 ) "*" "*" "*" " "
## 26 ( 1 ) "*" "*" "*" " "
## 27 ( 1 ) "*" "*" "*" " "
## 28 ( 1 ) "*" "*" "*" " "
## 29 ( 1 ) "*" "*" "*" " "
## 30 ( 1 ) "*" " " "*" "*"
## 31 ( 1 ) "*" " " "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## Monat_cJuli Monat_cJuni Monat_cMai Monat_cMärz Monat_cNovember
## 1 ( 1 ) " " " " " " " " " "
## 2 ( 1 ) " " " " " " " " " "
## 3 ( 1 ) " " " " " " " " " "
## 4 ( 1 ) " " " " " " " " " "
## 5 ( 1 ) " " " " " " " " " "
## 6 ( 1 ) " " " " " " " " " "
## 7 ( 1 ) " " " " " " " " " "
## 8 ( 1 ) " " " " " " " " " "
## 9 ( 1 ) " " " " " " " " " "
## 10 ( 1 ) " " " " " " " " "*"
## 11 ( 1 ) " " " " " " " " "*"
## 12 ( 1 ) " " " " " " " " "*"
## 13 ( 1 ) " " " " " " " " "*"
## 14 ( 1 ) " " " " " " " " "*"
## 15 ( 1 ) " " " " " " " " "*"
## 16 ( 1 ) " " " " " " " " "*"
## 17 ( 1 ) " " " " "*" " " "*"
## 18 ( 1 ) " " "*" "*" " " "*"
## 19 ( 1 ) " " "*" "*" " " "*"
## 20 ( 1 ) " " "*" "*" " " "*"
## 21 ( 1 ) "*" "*" "*" " " " "
## 22 ( 1 ) "*" "*" "*" " " " "
## 23 ( 1 ) "*" "*" "*" " " " "
## 24 ( 1 ) "*" "*" "*" " " " "
## 25 ( 1 ) "*" "*" "*" " " " "
## 26 ( 1 ) "*" "*" "*" " " " "
## 27 ( 1 ) "*" "*" "*" " " " "
## 28 ( 1 ) "*" "*" "*" " " " "
## 29 ( 1 ) "*" "*" "*" " " " "
## 30 ( 1 ) "*" "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*" "*"
## Monat_cOktober Monat_cSeptember SommerferienSH SommerferienNRW
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) " " " " " " " "
## 6 ( 1 ) " " " " " " " "
## 7 ( 1 ) " " " " " " " "
## 8 ( 1 ) " " " " " " " "
## 9 ( 1 ) " " " " "*" " "
## 10 ( 1 ) " " " " "*" " "
## 11 ( 1 ) " " " " "*" " "
## 12 ( 1 ) " " " " "*" " "
## 13 ( 1 ) " " " " "*" " "
## 14 ( 1 ) " " " " "*" " "
## 15 ( 1 ) " " " " "*" " "
## 16 ( 1 ) " " " " "*" " "
## 17 ( 1 ) " " " " "*" " "
## 18 ( 1 ) " " " " "*" " "
## 19 ( 1 ) " " " " "*" " "
## 20 ( 1 ) "*" " " "*" " "
## 21 ( 1 ) "*" "*" "*" " "
## 22 ( 1 ) "*" "*" "*" " "
## 23 ( 1 ) "*" "*" "*" " "
## 24 ( 1 ) "*" "*" "*" " "
## 25 ( 1 ) "*" "*" "*" " "
## 26 ( 1 ) "*" "*" "*" "*"
## 27 ( 1 ) "*" "*" "*" "*"
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## SommerferienNDS SommerferienHE Feiertag Ostern
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " "*" " "
## 4 ( 1 ) " " " " "*" " "
## 5 ( 1 ) " " " " "*" "*"
## 6 ( 1 ) " " " " "*" "*"
## 7 ( 1 ) " " " " "*" "*"
## 8 ( 1 ) " " " " "*" "*"
## 9 ( 1 ) " " " " "*" "*"
## 10 ( 1 ) " " " " "*" "*"
## 11 ( 1 ) " " " " "*" "*"
## 12 ( 1 ) " " " " "*" "*"
## 13 ( 1 ) " " " " "*" "*"
## 14 ( 1 ) " " " " "*" "*"
## 15 ( 1 ) " " " " "*" "*"
## 16 ( 1 ) " " " " "*" "*"
## 17 ( 1 ) " " " " "*" "*"
## 18 ( 1 ) " " " " "*" "*"
## 19 ( 1 ) " " " " "*" "*"
## 20 ( 1 ) " " " " "*" "*"
## 21 ( 1 ) " " " " "*" "*"
## 22 ( 1 ) " " " " "*" "*"
## 23 ( 1 ) " " " " "*" "*"
## 24 ( 1 ) "*" " " "*" "*"
## 25 ( 1 ) "*" " " "*" "*"
## 26 ( 1 ) "*" " " "*" "*"
## 27 ( 1 ) "*" " " "*" "*"
## 28 ( 1 ) "*" " " "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" " " "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## ChristiHimmelfahrt Pfingsten TDE Ostern_ext
## 1 ( 1 ) " " " " " " " "
## 2 ( 1 ) " " " " " " " "
## 3 ( 1 ) " " " " " " " "
## 4 ( 1 ) " " " " " " " "
## 5 ( 1 ) "*" "*" "*" " "
## 6 ( 1 ) "*" "*" "*" " "
## 7 ( 1 ) "*" "*" "*" " "
## 8 ( 1 ) "*" "*" "*" " "
## 9 ( 1 ) "*" "*" "*" " "
## 10 ( 1 ) "*" "*" "*" " "
## 11 ( 1 ) "*" "*" "*" " "
## 12 ( 1 ) "*" "*" "*" "*"
## 13 ( 1 ) "*" "*" "*" "*"
## 14 ( 1 ) "*" "*" "*" "*"
## 15 ( 1 ) "*" "*" "*" "*"
## 16 ( 1 ) "*" "*" "*" "*"
## 17 ( 1 ) "*" "*" "*" "*"
## 18 ( 1 ) "*" "*" "*" "*"
## 19 ( 1 ) "*" "*" "*" "*"
## 20 ( 1 ) "*" "*" "*" "*"
## 21 ( 1 ) "*" "*" "*" "*"
## 22 ( 1 ) "*" "*" "*" "*"
## 23 ( 1 ) "*" "*" "*" "*"
## 24 ( 1 ) "*" "*" "*" "*"
## 25 ( 1 ) "*" "*" "*" "*"
## 26 ( 1 ) "*" "*" "*" "*"
## 27 ( 1 ) "*" "*" "*" "*"
## 28 ( 1 ) "*" "*" "*" "*"
## 29 ( 1 ) "*" "*" "*" "*"
## 30 ( 1 ) "*" "*" "*" "*"
## 31 ( 1 ) "*" "*" "*" "*"
## 32 ( 1 ) "*" "*" "*" "*"
## 33 ( 1 ) "*" "*" "*" "*"
## 34 ( 1 ) "*" "*" "*" "*"
## 35 ( 1 ) "*" "*" "*" "*"
## 36 ( 1 ) "*" "*" "*" "*"
## 37 ( 1 ) "*" "*" "*" "*"
## ChristiHimmelfahrt_ext Pfingsten_ext Silvester_ext
## 1 ( 1 ) " " " " "*"
## 2 ( 1 ) " " " " "*"
## 3 ( 1 ) " " " " "*"
## 4 ( 1 ) " " " " "*"
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " " " " "
## 7 ( 1 ) " " " " " "
## 8 ( 1 ) " " " " " "
## 9 ( 1 ) " " " " " "
## 10 ( 1 ) " " " " " "
## 11 ( 1 ) " " " " "*"
## 12 ( 1 ) " " " " "*"
## 13 ( 1 ) " " " " "*"
## 14 ( 1 ) " " " " "*"
## 15 ( 1 ) " " " " "*"
## 16 ( 1 ) " " " " "*"
## 17 ( 1 ) " " " " "*"
## 18 ( 1 ) " " " " "*"
## 19 ( 1 ) " " " " "*"
## 20 ( 1 ) " " " " "*"
## 21 ( 1 ) " " " " "*"
## 22 ( 1 ) " " " " "*"
## 23 ( 1 ) " " " " "*"
## 24 ( 1 ) " " " " "*"
## 25 ( 1 ) " " " " "*"
## 26 ( 1 ) " " " " "*"
## 27 ( 1 ) " " " " "*"
## 28 ( 1 ) " " " " "*"
## 29 ( 1 ) " " " " "*"
## 30 ( 1 ) " " " " "*"
## 31 ( 1 ) " " " " "*"
## 32 ( 1 ) " " " " "*"
## 33 ( 1 ) " " "*" "*"
## 34 ( 1 ) " " "*" "*"
## 35 ( 1 ) " " "*" "*"
## 36 ( 1 ) " " "*" "*"
## 37 ( 1 ) "*" "*" "*"
## JahreszeitHerbst JahreszeitSommer JahreszeitWinter
## 1 ( 1 ) " " " " " "
## 2 ( 1 ) " " "*" " "
## 3 ( 1 ) " " "*" " "
## 4 ( 1 ) " " "*" " "
## 5 ( 1 ) " " " " " "
## 6 ( 1 ) " " "*" " "
## 7 ( 1 ) " " "*" " "
## 8 ( 1 ) " " "*" " "
## 9 ( 1 ) "*" " " " "
## 10 ( 1 ) " " " " " "
## 11 ( 1 ) " " " " " "
## 12 ( 1 ) " " " " " "
## 13 ( 1 ) " " "*" " "
## 14 ( 1 ) " " "*" " "
## 15 ( 1 ) " " "*" " "
## 16 ( 1 ) " " "*" " "
## 17 ( 1 ) " " "*" " "
## 18 ( 1 ) " " "*" " "
## 19 ( 1 ) " " "*" " "
## 20 ( 1 ) " " "*" " "
## 21 ( 1 ) "*" " " " "
## 22 ( 1 ) "*" " " "*"
## 23 ( 1 ) "*" " " "*"
## 24 ( 1 ) "*" " " "*"
## 25 ( 1 ) "*" " " "*"
## 26 ( 1 ) "*" " " "*"
## 27 ( 1 ) "*" " " "*"
## 28 ( 1 ) "*" " " "*"
## 29 ( 1 ) "*" " " "*"
## 30 ( 1 ) "*" " " "*"
## 31 ( 1 ) "*" " " "*"
## 32 ( 1 ) "*" " " "*"
## 33 ( 1 ) "*" " " "*"
## 34 ( 1 ) "*" "*" "*"
## 35 ( 1 ) "*" " " "*"
## 36 ( 1 ) "*" "*" "*"
## 37 ( 1 ) "*" "*" "*"
Für ein Modell mit einer Variablen kann beobachtet werden, dass die Variable Silvester_ext ein Sternchen hat, was signalisiert, dass ein Regressionsmodell mit Umsatz ~ Silvester_ext das beste Einzelvariablenmodell ist. Das beste 2-Variablen-Modell ist Umsatz ~ Silvester_ext + JahreszeitSommer. Das beste 3-Variablen-Modell ist Umsatz ~ Silvester_ext + JahreszeitSommer + Feiertag. Und so weiter.
Schrittweise Auswahl (“Stepwise selection”)
Schrittweise vorwärts (Forward stepwise)
Die schrittweise Vorwärtsauswahl kann mit regsubsets durchgeführt werden, indem die method = "forward" gesetzt wird:
Schrittweise rückwärts (Backward stepwise)
Die schrittweise Vorwärtsauswahl kann mit regsubsets durchgeführt werden, indem die method = "backward" gesetzt wird:
Modellauswahl
Indirekte Schätzung des Testfehlers mit \(C_{p}\), \(AIC\), \(BIC\) und adjustiertem \(R^2\)
results <- summary(best_subset_WG5)
# Extrahieren und plotten der Ergebnisse
tibble(predictors = 1:37,
adj_R2 = results$adjr2,
Cp = results$cp,
BIC = results$bic) %>%
gather(statistic, value, -predictors) %>%
ggplot(aes(predictors, value, color = statistic)) +
geom_line(show.legend = F) +
geom_point(show.legend = F) +
facet_wrap(~ statistic, scales = "free")## [1] 31
## [1] 22
## [1] 27
Es ist erkennbar, dass die Ergebnisse leicht unterschiedliche Modelle identifizieren, die als die besten angesehen werden. Die ajustierte \(R^2\)-Statistik legt nahe, dass ein 31-Variablen-Modell bevorzugt wird, die \(BIC\)-Statistik schlägt ein 22-Variablenmodell vor und der \(C_{p}\) ein 27-Variablen-Modell vor.
Wir vergleichen das Ergebnis mit denen der stepwise selection:
## [1] 27
## [1] 29
Wenn man das optimale \(C_{p}\) für vorwärts und rückwärts schrittweise bewertet, ist erkennbar, dass gemäß der Vorwärts-Methode ein 27-Variablen-Modell die \(C_{p}\)-Statistik minimiert. Die Rückwärtsmethode schlägt ein 29-Variablen-Modell vor.
Wenn wir die Modelle der subset selection vergleichen, ergibt sich bzgl. der Zusammensetzung der Prädikatoren folgendes Bild:.
## (Intercept) Temperatur Wochentag_cFreitag
## 254.738374 -2.266673 16.123187
## Wochentag_cSamstag Wochentag_cSonntag Monat_cAugust
## 50.660451 48.892227 66.493506
## Monat_cDezember Monat_cFebruar Monat_cJuli
## -21.024805 29.821237 48.148185
## Monat_cJuni Monat_cMai Monat_cOktober
## 39.950741 28.252117 53.586614
## Monat_cSeptember SommerferienSH Feiertag
## 54.678777 26.839961 1253.501439
## Ostern ChristiHimmelfahrt Pfingsten
## -1371.682393 -1201.197389 -1208.451384
## TDE Ostern_ext Silvester_ext
## -1195.229972 153.788742 175.066611
## JahreszeitHerbst JahreszeitWinter
## -41.102070 -14.890257
## (Intercept) KielerWoche Bewoelkung
## 268.032007 15.863106 -1.468629
## Temperatur Wochentag_cFreitag Wochentag_cMontag
## -2.671124 13.717486 -10.726879
## Wochentag_cSamstag Wochentag_cSonntag Monat_cAugust
## 48.062902 45.529362 59.156961
## Monat_cDezember Monat_cFebruar Monat_cJuli
## -20.380110 30.345489 30.847401
## Monat_cJuni Monat_cMai Monat_cOktober
## 34.682821 29.614819 55.411584
## Monat_cSeptember SommerferienSH SommerferienNRW
## 57.018065 20.959567 13.754971
## SommerferienNDS Feiertag Ostern
## 17.734031 1255.352329 -1366.854091
## ChristiHimmelfahrt Pfingsten TDE
## -1207.205006 -1203.650200 -1195.259264
## Ostern_ext Silvester_ext JahreszeitHerbst
## 151.309360 174.404916 -40.936587
## JahreszeitWinter
## -15.714840
## (Intercept) KielerWoche Bewoelkung
## 255.6442683 16.4911414 -1.5661465
## Temperatur Windgeschwindigkeit Wochentag_cFreitag
## -2.6350940 0.4225708 13.9311125
## Wochentag_cMontag Wochentag_cSamstag Wochentag_cSonntag
## -10.6928427 48.4432933 45.7160795
## Monat_cAugust Monat_cFebruar Monat_cJanuar
## 64.2304244 49.9045166 19.6944957
## Monat_cJuli Monat_cJuni Monat_cMai
## 37.3987138 42.3978429 36.6484061
## Monat_cMärz Monat_cNovember Monat_cOktober
## 18.9266262 18.4775466 72.8677620
## Monat_cSeptember SommerferienSH SommerferienNRW
## 67.5339084 19.0408018 13.3216502
## SommerferienNDS SommerferienHE Feiertag
## 14.3478219 8.2354791 1253.9685005
## Ostern ChristiHimmelfahrt Pfingsten
## -1365.8199310 -1205.6473118 -1202.1935466
## TDE Ostern_ext Silvester_ext
## -1195.4186280 153.0112693 174.2224552
## JahreszeitHerbst JahreszeitWinter
## -50.4376536 -27.3221036
Betrachtet man die Variablenauswahl der stepwise selection genauer, ergibt sich folgendes Bild:
## (Intercept) Bewoelkung Temperatur
## 265.505078 -1.446825 -2.584725
## Wochentag_cFreitag Wochentag_cMontag Wochentag_cSamstag
## 13.620128 -10.573699 48.620543
## Wochentag_cSonntag Monat_cAugust Monat_cDezember
## 46.038233 45.488650 -26.460117
## Monat_cFebruar Monat_cJuli Monat_cJuni
## 29.651459 29.364119 37.989729
## Monat_cMai Monat_cNovember Monat_cOktober
## 30.581955 -7.302670 47.030766
## Monat_cSeptember SommerferienSH SommerferienHE
## 42.234937 23.729266 14.203924
## Feiertag Ostern ChristiHimmelfahrt
## 1255.017639 -1366.527389 -1206.677670
## Pfingsten TDE Ostern_ext
## -1204.176488 -1195.182448 152.692199
## Silvester_ext JahreszeitHerbst JahreszeitSommer
## 179.798487 -31.350914 17.428428
## JahreszeitWinter
## -13.109788
## (Intercept) KielerWoche Bewoelkung
## 260.530989 15.819133 -1.522818
## Temperatur Wochentag_cFreitag Wochentag_cMontag
## -2.601691 13.805732 -10.860807
## Wochentag_cSamstag Wochentag_cSonntag Monat_cAugust
## 48.216251 45.499928 65.984160
## Monat_cFebruar Monat_cJanuar Monat_cJuli
## 49.720382 19.352472 37.360180
## Monat_cJuni Monat_cMai Monat_cMärz
## 41.137152 36.232873 18.901279
## Monat_cNovember Monat_cOktober Monat_cSeptember
## 18.507187 72.910246 66.596185
## SommerferienSH SommerferienNRW SommerferienNDS
## 20.353220 13.853114 17.700078
## Feiertag Ostern ChristiHimmelfahrt
## 1255.332792 -1369.130553 -1207.186049
## Pfingsten TDE Ostern_ext
## -1203.353303 -1195.431419 154.574417
## Silvester_ext JahreszeitHerbst JahreszeitWinter
## 173.361597 -51.493638 -27.542531
Direkte Schätzung des Testfehlers
Nun wird der Fehler der Testdaten für das beste Modell jeder Modellgröße berechnet. Zuerst wird eine Modellmatrix aus den Testdaten erstellt. Die Funktion model.matrix wird in vielen Regressionspaketen zum Erstellen einer X-Matrix aus Daten verwendet.
Jetzt kann jede Modellgröße (d.h. 1 Variable, 2 Variablen,…, 20 Variablen) durchlaufen werden und die Koeffizienten für das beste Modell dieser Größe extrahiert werden. Diese Werte werden sodann in die entsprechenden Spalten der Testmodellmatrix multipliziert, um die Vorhersagen zu bilden. Dann werden die Test-MSE berechnet.
# Erstellen eines leeren Vektors, um diesen nachfolgend mit den Fehlerwerten zu füllen
validation_errors <- vector("double", length = 37)
for(i in 1:37) {
coef_x <- coef(best_subset_WG5, id = i) # extract coefficients for model size i
pred_x <- test_m[ , names(coef_x)] %*% coef_x # predict salary using matrix algebra
validation_errors[i] <- mean((df_lm_test_WG5$Umsatz - pred_x)^2) # compute test error btwn actual & predicted salary
}
as.matrix(validation_errors)## [,1]
## [1,] 5972.861
## [2,] 5227.094
## [3,] 4819.721
## [4,] 4646.655
## [5,] 3686.944
## [6,] 2932.984
## [7,] 2786.784
## [8,] 2621.067
## [9,] 3287.711
## [10,] 3186.449
## [11,] 3146.983
## [12,] 3225.637
## [13,] 2898.322
## [14,] 2886.311
## [15,] 2853.389
## [16,] 2875.855
## [17,] 2882.090
## [18,] 2886.838
## [19,] 2910.222
## [20,] 2857.982
## [21,] 2725.497
## [22,] 2731.256
## [23,] 2751.364
## [24,] 2779.303
## [25,] 2784.116
## [26,] 2794.999
## [27,] 2769.351
## [28,] 2766.063
## [29,] 2757.304
## [30,] 2774.713
## [31,] 2766.101
## [32,] 2776.358
## [33,] 2774.969
## [34,] 2770.578
## [35,] 2772.174
## [36,] 2767.774
## [37,] 2769.099
#############################
# Alternative: http://www.science.smith.edu/~jcrouser/SDS293/labs/lab9-r.html
val_errors = rep(NA, 37)
# Iterationen über jede Größe i
for(i in 1:37){
# Extrahieren des Vektors der Prädiktoren im Best-Fit-Modell für i-Prädiktoren
coefi = coef(best_subset_WG5, id = i)
# Vorhersagen unter Verwendung der Matrixmultiplikation der Testmatrix und des Koeffizientenvektors erstellen
pred = test_m[,names(coefi)]%*%coefi
# Berechnung des MSE
val_errors[i] = mean((df_lm_test_WG5$Umsatz-pred)^2)
}
# Auffinden des Modells mit dem kleinsten Fehler
min = which.min(val_errors)
# Plotten des Fehlers für jede Modellgröße
plot(val_errors, type = 'b')
points(min, val_errors[min][1], col = "red", cex = 2, pch = 20)Es ist erkennbar, dass das 8-Variablen-Modell, das durch den besten Teilmengenansatz erzeugt wird, den niedrigsten Test-MSE erzeugt. Auch ein 21-Variablen-Modell scheint vergleichweichsweise gut zu performen.
Wir können jetzt die beste Teilmengenauswahl für den gesamten Datensatz durchführen, um zum einen das 16-Variablen-Modell zu erhalten. Dieses Modell wird mit dem 10-und dem 28-Variablen-Modell verglichen.
Teilmengenauswahl für das 8-Variablen-Modell
final_best_WG5_8 <- regsubsets(Umsatz ~ ., data = df_lm_train_WG5, nvmax = 37)
coef(final_best_WG5_8, 8)## (Intercept) Wochentag_cSamstag Wochentag_cSonntag
## 234.54873 51.98672 44.09080
## Feiertag Ostern ChristiHimmelfahrt
## 1402.59210 -1363.16956 -1335.99749
## Pfingsten TDE JahreszeitSommer
## -1334.68456 -1344.65307 47.34359
Die 8 Variablen sind die folgenden:
- Wochentag_cSamstag
- Wochentag_cSonntag
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- JahreszeitSommer
Die Variablen Wochentag_c, Monat_c und Jahreszeit müssen nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG5_8 <- df_lm_train_WG5 %>%
mutate(Montag=as.integer(df_lm_train_WG5$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG5$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG5$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG5$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG5$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG5$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG5$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG5$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG5$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG5$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG5$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG5$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG5$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG5$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG5$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG5$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG5$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG5$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG5$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG5$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG5$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG5$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG5$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG5_8 <- df_lm_test_WG5 %>%
mutate(Montag=as.integer(df_lm_test_WG5$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG5$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG5$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG5$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG5$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG5$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG5$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG5$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG5$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG5$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG5$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG5$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG5$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG5$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG5$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG5$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG5$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG5$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG5$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG5$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG5$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG5$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG5$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 8-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG5_8_train <- lm(Umsatz ~ Samstag + Sonntag + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + Sommer, data = df_lm_train_WG5_8)
glance(lm_WG5_8_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.726 0.724 49.9 348. 2.83e-289 9 -5649. 11318.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 51.1963561 0.7246812 38.9197760
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG5_8 <- df_lm_test_WG5_8 %>%
mutate(predicted = lm_WG5_8_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG5_8 <-df_lm_test_WG5_8 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG5_8 <- df_lm_test_WG5_8 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG5_8 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best8_bss_WG5")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 16 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6
## 3 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4
## 4 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4
## 5 346 130413. 377. 39.8 3.37 11.4 10.6 2708. 52.0
## 6 346 130413. 377. 39.8 3.45 11.4 10.6 2722. 52.2
## 7 346 130413. 377. 40.3 3.48 11.6 10.7 2768. 52.6
## 8 346 130413. 377. 39.9 3.52 11.5 10.6 2720. 52.2
## 9 346 59316. 171. 31.2 -8.4 17.3 18.2 1751. 41.8
## 10 346 59316. 171. 30.9 -8.38 17.4 18.0 1722. 41.5
## 11 345 28354. 82.2 17.7 13.7 24.5 21.5 526. 22.9
## 12 345 28354. 82.2 18.3 12.0 24.2 22.2 607. 24.6
## 13 345 28354. 82.2 18.1 11.6 23.8 22.1 593. 24.4
## 14 345 28354. 82.2 18.2 11.5 23.9 22.2 599. 24.5
## 15 345 28354. 82.2 18.4 12.1 24.2 22.3 604. 24.6
## 16 346 93912. 271. 38.9 0.87 14.6 14.3 2621. 51.2
## # ... with 2 more variables: rRMSE <dbl>, Modell <chr>
Teilmengenauswahl für das 22-Variablen-Modell gemäß best subset selection
Die 22 Variablen sind die folgenden:
- Temperatur
- Wochentag_cFreitag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cAugust
- Monat_cDezember
- Monat_cFebruar
- Monat_cJuli
- Monat_cJuni
- Monat_cMai
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- Silvester_ext
- JahreszeitHerbst
- JahreszeitWinter
Die Variablen Wochentag_c, Monat_c und Jahreszeit müssen nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG5_22 <- df_lm_train_WG5 %>%
mutate(Montag=as.integer(df_lm_train_WG5$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG5$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG5$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG5$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG5$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG5$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG5$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG5$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG5$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG5$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG5$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG5$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG5$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG5$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG5$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG5$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG5$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG5$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG5$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG5$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG5$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG5$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG5$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG5_22 <- df_lm_test_WG5 %>%
mutate(Montag=as.integer(df_lm_test_WG5$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG5$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG5$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG5$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG5$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG5$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG5$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG5$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG5$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG5$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG5$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG5$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG5$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG5$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG5$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG5$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG5$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG5$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG5$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG5$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG5$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG5$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG5$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 22-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG5_22_train <- lm(Umsatz ~ Temperatur + Freitag + Samstag + Sonntag + August + Dezember + Februar + Juli + Juni + Mai + Oktober + September + SommerferienSH + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + Ostern_ext + Silvester_ext + Herbst + Sommer, data = df_lm_train_WG5_22)
glance(lm_WG5_22_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.803 0.799 42.5 193. 0 23 -5473. 10994.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 51.8482483 0.7188751 38.9361476
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG5_22 <- df_lm_test_WG5_22 %>%
mutate(predicted = lm_WG5_22_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG5_22 <-df_lm_test_WG5_22 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG5_22 <- df_lm_test_WG5_22 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG5_22 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best22_bss_WG5")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 17 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6
## 3 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4
## 4 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4
## 5 346 130413. 377. 39.8 3.37 11.4 10.6 2708. 52.0
## 6 346 130413. 377. 39.8 3.45 11.4 10.6 2722. 52.2
## 7 346 130413. 377. 40.3 3.48 11.6 10.7 2768. 52.6
## 8 346 130413. 377. 39.9 3.52 11.5 10.6 2720. 52.2
## 9 346 59316. 171. 31.2 -8.4 17.3 18.2 1751. 41.8
## 10 346 59316. 171. 30.9 -8.38 17.4 18.0 1722. 41.5
## 11 345 28354. 82.2 17.7 13.7 24.5 21.5 526. 22.9
## 12 345 28354. 82.2 18.3 12.0 24.2 22.2 607. 24.6
## 13 345 28354. 82.2 18.1 11.6 23.8 22.1 593. 24.4
## 14 345 28354. 82.2 18.2 11.5 23.9 22.2 599. 24.5
## 15 345 28354. 82.2 18.4 12.1 24.2 22.3 604. 24.6
## 16 346 93912. 271. 38.9 0.87 14.6 14.3 2621. 51.2
## 17 346 93912. 271. 38.9 -0.05 14.5 14.4 2688. 51.8
## # ... with 2 more variables: rRMSE <dbl>, Modell <chr>
Teilmengenauswahl für das 27-Variablen-Modell gemäß best subset selection
Die 27 Variablen sind die folgenden:
- KielerWoche
- Bewoelkung
- Temperatur
- Wochentag_cFreitag
- Wochentag_cMontag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cAugust
- Monat_cDezember
- Monat_cFebruar
- Monat_cJuli
- Monat_cJuni
- Monat_cMai
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- Silvester_ext
- JahreszeitHerbst
- JahreszeitWinter
Die Variablen Wochentag_c, Monat_c und Jahreszeit müssen nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG5_27 <- df_lm_train_WG5 %>%
mutate(Montag=as.integer(df_lm_train_WG5$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG5$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG5$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG5$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG5$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG5$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG5$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG5$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG5$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG5$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG5$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG5$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG5$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG5$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG5$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG5$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG5$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG5$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG5$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG5$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG5$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG5$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG5$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG5_27 <- df_lm_test_WG5 %>%
mutate(Montag=as.integer(df_lm_test_WG5$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG5$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG5$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG5$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG5$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG5$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG5$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG5$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG5$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG5$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG5$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG5$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG5$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG5$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG5$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG5$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG5$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG5$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG5$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG5$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG5$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG5$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG5$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 27-Variablenmodell wird nun ein Regressionsmodell erstellt:
lm_WG5_27_train <- lm(Umsatz ~ KielerWoche + Bewoelkung + Temperatur + Freitag + Montag + Samstag + Sonntag + August + Dezember + Februar + Juli + Juni + Mai + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienNDS + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + Ostern_ext + Silvester_ext + Herbst + Winter, data = df_lm_train_WG5_27)
glance(lm_WG5_27_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.808 0.803 42.1 161. 0 28 -5459. 10977.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 52.6246269 0.7097689 39.2765909
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG5_27 <- df_lm_test_WG5_27 %>%
mutate(predicted = lm_WG5_27_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG5_27 <-df_lm_test_WG5_27 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG5_27 <- df_lm_test_WG5_27 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG5_27 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best27_bss_WG5")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 18 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6
## 3 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4
## 4 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4
## 5 346 130413. 377. 39.8 3.37 11.4 10.6 2708. 52.0
## 6 346 130413. 377. 39.8 3.45 11.4 10.6 2722. 52.2
## 7 346 130413. 377. 40.3 3.48 11.6 10.7 2768. 52.6
## 8 346 130413. 377. 39.9 3.52 11.5 10.6 2720. 52.2
## 9 346 59316. 171. 31.2 -8.4 17.3 18.2 1751. 41.8
## 10 346 59316. 171. 30.9 -8.38 17.4 18.0 1722. 41.5
## 11 345 28354. 82.2 17.7 13.7 24.5 21.5 526. 22.9
## 12 345 28354. 82.2 18.3 12.0 24.2 22.2 607. 24.6
## 13 345 28354. 82.2 18.1 11.6 23.8 22.1 593. 24.4
## 14 345 28354. 82.2 18.2 11.5 23.9 22.2 599. 24.5
## 15 345 28354. 82.2 18.4 12.1 24.2 22.3 604. 24.6
## 16 346 93912. 271. 38.9 0.87 14.6 14.3 2621. 51.2
## 17 346 93912. 271. 38.9 -0.05 14.5 14.4 2688. 51.8
## 18 346 93912. 271. 39.3 0.1 14.6 14.5 2769. 52.6
## # ... with 2 more variables: rRMSE <dbl>, Modell <chr>
Teilmengenauswahl für das 27-Variablen-Modell gemäß forward selection
Für das 27-Variablenmodell gemäß forward selection wird nun ein Regressionsmodell erstellt:
lm_WG5_27_train_for <- lm(Umsatz ~ Bewoelkung + Temperatur + Freitag + Montag + Samstag + Sonntag + August + Dezember + Februar + Juli + Juni + Mai + November + Oktober + September + SommerferienSH + SommerferienHE + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + Ostern_ext + Silvester_ext + Herbst + Sommer + Winter, data = df_lm_train_WG5_27)
glance(lm_WG5_27_train_for)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.808 0.803 42.2 161. 0 28 -5461. 10980.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 52.4067514 0.7119959 39.3203782
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG5_27 <- df_lm_test_WG5_27 %>%
mutate(predicted = lm_WG5_27_predict_for)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG5_27 <-df_lm_test_WG5_27 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG5_27 <- df_lm_test_WG5_27 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG5_27 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best27_forward_WG5")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 19 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6
## 3 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4
## 4 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4
## 5 346 130413. 377. 39.8 3.37 11.4 10.6 2708. 52.0
## 6 346 130413. 377. 39.8 3.45 11.4 10.6 2722. 52.2
## 7 346 130413. 377. 40.3 3.48 11.6 10.7 2768. 52.6
## 8 346 130413. 377. 39.9 3.52 11.5 10.6 2720. 52.2
## 9 346 59316. 171. 31.2 -8.4 17.3 18.2 1751. 41.8
## 10 346 59316. 171. 30.9 -8.38 17.4 18.0 1722. 41.5
## 11 345 28354. 82.2 17.7 13.7 24.5 21.5 526. 22.9
## 12 345 28354. 82.2 18.3 12.0 24.2 22.2 607. 24.6
## 13 345 28354. 82.2 18.1 11.6 23.8 22.1 593. 24.4
## 14 345 28354. 82.2 18.2 11.5 23.9 22.2 599. 24.5
## 15 345 28354. 82.2 18.4 12.1 24.2 22.3 604. 24.6
## 16 346 93912. 271. 38.9 0.87 14.6 14.3 2621. 51.2
## 17 346 93912. 271. 38.9 -0.05 14.5 14.4 2688. 51.8
## 18 346 93912. 271. 39.3 0.1 14.6 14.5 2769. 52.6
## 19 346 93912. 271. 39.3 0.13 14.6 14.5 2746. 52.4
## # ... with 2 more variables: rRMSE <dbl>, Modell <chr>
Teilmengenauswahl für das 29-Variablen-Modell gemäß backward selection
Die 29 Variablen sind die folgenden:
- KielerWoche
- Bewoelkung
- Temperatur
- Wochentag_cFreitag
- Wochentag_cMontag
- Wochentag_cSamstag
- Wochentag_cSonntag
- Monat_cAugust
- Monat_cFebruar
- Monat_cJanuar
- Monat_cJuli
- Monat_cJuni
- Monat_cMai
- Monat_cMärz
- Monat_cNovember
- Monat_cOktober
- Monat_cSeptember
- SommerferienSH
- SommerferienNRW
- SommerferienNDS
- Feiertag
- Ostern
- ChristiHimmelfahrt
- Pfingsten
- TDE
- Ostern_ext
- Silvester_ext
- JahreszeitHerbst
- JahreszeitWinter
Die Variablen Wochentag_c, Monat_c und Jahreszeit müssen nun noch dummyfiziert werden (bei Einbeziehung aller Variablen erfolgt die Dummyfizierung automatisch im Rahmen der Regressionsanalyse): Für jeden Wochentag wird eine Variable mit Ausprägung 0/1 gebildet und danach die alte Variable Wochentag_c entfernt. Analog wird bei den beiden anderen Variablen vorgegangen.
# Dummyfizierung der Variablen im Trainigsdatensatz:
df_lm_train_WG5_29 <- df_lm_train_WG5 %>%
mutate(Montag=as.integer(df_lm_train_WG5$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_train_WG5$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_train_WG5$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_train_WG5$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_train_WG5$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_train_WG5$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_train_WG5$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_train_WG5$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_train_WG5$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_train_WG5$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_train_WG5$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_train_WG5$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_train_WG5$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_train_WG5$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_train_WG5$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_train_WG5$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_train_WG5$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_train_WG5$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_train_WG5$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_train_WG5$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_train_WG5$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_train_WG5$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_train_WG5$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)
df_lm_test_WG5_29 <- df_lm_test_WG5 %>%
mutate(Montag=as.integer(df_lm_test_WG5$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_lm_test_WG5$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_lm_test_WG5$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_lm_test_WG5$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_lm_test_WG5$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_lm_test_WG5$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_lm_test_WG5$Wochentag_c=="Sonntag")) %>%
mutate(Januar=as.integer(df_lm_test_WG5$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_lm_test_WG5$Monat_c=="Februar")) %>%
mutate(Maerz=as.integer(df_lm_test_WG5$Monat_c=="März")) %>%
mutate(April=as.integer(df_lm_test_WG5$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_lm_test_WG5$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_lm_test_WG5$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_lm_test_WG5$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_lm_test_WG5$Monat_c=="August")) %>%
mutate(September=as.integer(df_lm_test_WG5$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_lm_test_WG5$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_lm_test_WG5$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_lm_test_WG5$Monat_c=="Dezember")) %>%
mutate(Fruehling=as.integer(df_lm_test_WG5$Jahreszeit=="Fruehling")) %>%
mutate(Sommer=as.integer(df_lm_test_WG5$Jahreszeit=="Sommer")) %>%
mutate(Herbst=as.integer(df_lm_test_WG5$Jahreszeit=="Herbst")) %>%
mutate(Winter=as.integer(df_lm_test_WG5$Jahreszeit=="Winter")) %>%
dplyr::select(-Wochentag_c, -Monat_c, -Jahreszeit)Für das 29-Variablenmodell gemäß backward selection wird nun ein Regressionsmodell erstellt:
lm_WG5_29_train <- lm(Umsatz ~ KielerWoche + Bewoelkung + Temperatur + Freitag + Montag + Samstag + Sonntag + August + Februar + Januar + Juli + Juni + Mai + Maerz + November + Oktober + September + SommerferienSH + SommerferienNRW + SommerferienNDS + Feiertag + Ostern + ChristiHimmelfahrt + Pfingsten + TDE + Ostern_ext + Silvester_ext + Herbst + Winter, data = df_lm_train_WG5_29)
glance(lm_WG5_29_train)## # A tibble: 1 x 11
## r.squared adj.r.squared sigma statistic p.value df logLik AIC
## <dbl> <dbl> <dbl> <dbl> <dbl> <int> <dbl> <dbl>
## 1 0.809 0.803 42.1 150. 0 30 -5458. 10978.
## # ... with 3 more variables: BIC <dbl>, deviance <dbl>, df.residual <int>
Dann wird (die Modellgüte) anhand der Test-Stichprobe getestet:
Als Ergebnis wird ein Vektor erzeugt, der für jede Beobachtung des Test-Samples den geschätzten (vorhergesagten) Umsatzwert speichert. Die Gütewerte lassen sich mit caret::postResample ausgeben:
## RMSE Rsquared MAE
## 52.7229373 0.7088223 39.1048137
Diese Vorhersage-Ergebnisse werden den Test-Daten hinzugefügt, sodann die Gütekennzahlen berechnet, die wiederum der gemeinsamen Übersichtstabelle für die Gütekennzahlen lm_vgl_kennz hinzugefügt werden:
# Hinzufügen der Ergebnisse
df_lm_test_WG5_29 <- df_lm_test_WG5_29 %>%
mutate(predicted = lm_WG5_29_predict)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_lm_test_WG5_29 <-df_lm_test_WG5_29 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_lm_test_WG5_29 <- df_lm_test_WG5_29 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_lm_test_WG5_29 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "best29_backward_WG5")
# füge die Kennzahlen nun an die Vergleichstabelle
lm_vgl_kennz <- rbind(lm_vgl_kennz, temp)
lm_vgl_kennz## # A tibble: 20 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 24.8 -7.84 18.7 18.8 1067. 32.7
## 2 346 45738. 132. 24.8 -7.65 18.8 18.8 1064. 32.6
## 3 346 45738. 132. 24.7 -7.93 18.5 18.7 1050. 32.4
## 4 346 45738. 132. 24.7 -7.91 18.6 18.7 1050. 32.4
## 5 346 130413. 377. 39.8 3.37 11.4 10.6 2708. 52.0
## 6 346 130413. 377. 39.8 3.45 11.4 10.6 2722. 52.2
## 7 346 130413. 377. 40.3 3.48 11.6 10.7 2768. 52.6
## 8 346 130413. 377. 39.9 3.52 11.5 10.6 2720. 52.2
## 9 346 59316. 171. 31.2 -8.4 17.3 18.2 1751. 41.8
## 10 346 59316. 171. 30.9 -8.38 17.4 18.0 1722. 41.5
## 11 345 28354. 82.2 17.7 13.7 24.5 21.5 526. 22.9
## 12 345 28354. 82.2 18.3 12.0 24.2 22.2 607. 24.6
## 13 345 28354. 82.2 18.1 11.6 23.8 22.1 593. 24.4
## 14 345 28354. 82.2 18.2 11.5 23.9 22.2 599. 24.5
## 15 345 28354. 82.2 18.4 12.1 24.2 22.3 604. 24.6
## 16 346 93912. 271. 38.9 0.87 14.6 14.3 2621. 51.2
## 17 346 93912. 271. 38.9 -0.05 14.5 14.4 2688. 51.8
## 18 346 93912. 271. 39.3 0.1 14.6 14.5 2769. 52.6
## 19 346 93912. 271. 39.3 0.13 14.6 14.5 2746. 52.4
## 20 346 93912. 271. 39.1 0.08 14.5 14.4 2780. 52.7
## # ... with 2 more variables: rRMSE <dbl>, Modell <chr>
Auch für Warengruppe 5 ergibt sich ein ähnliches Bild wie für alle anderen Warengruppen: Die Modelle weichen nur marginal voneinander ab. Je nachdem, ob man den MPE oder den RMSE als finales Entscheidungskriteirum heranzieht, performt im ersten Fall das 22-Variablen-Modell am besten, im letzteren das 8-Variablen-Modell.
6.4 Vergleich der linearen Modelle
Wir haben jetzt die Gütekennzahlen für sämtliche Warengruppen für verschiedene Modelle ermittelt. Innerhalb der Warengruppen unterscheiden sich die Modelle nur marginal. Die besten Modelle für die Warengruppen sind:
- Warengruppe 1: 21 Variablen
- Warengruppe 2: 24 Variablen
- Warengruppe 3: 30 Variablen
- Warengruppe 4: 1 Variablen
- Warengruppe 5: 8 Variablen.
In Anlehnung an gängiges Vorgehen in der Praxis wurde jeweils das einfachste Modell gewählt, also das mit möglichst wenig Variablen.
Dann fällt auf, dass die Schätzer für die Warengruppe 1 und 3 offenbar systematisch zu niedrig sind, weil die mittlere relative Abweichung bei -8% liegt. Warengruppe 4 wird dagegen konsequent zu hoch geschätzt. Für die Warengruppen 2 und 5 liegt der Wert näher an Null bzw. ist gleich 0.
Und der mittlere gewichtete Absolutwert der relativen Abweichung (WAPE), den wir vorrangig als Güte-Kriterium im Auge haben, zeigt den niedrigsten Wert für Warengruppe 2, gefolgt von Warengruppe 5. Ähnliche Ergebnisse hatten wir auch mit dem besten naiven Modell erzielt: Dort konnten mit dem erweiterten gleitenden Durchschnitt der letzten 4 Wochen- bzw. Wochenendtage die besten Ergebnisse für die Warengruppen insgesamt erzielt werden und für die Warengruppe 2 lag der WAPE ebenfalls bei 11.
Wir widmen uns nun den Verfahren aus dem Bereich Machine Learning und Deep Learning und wollen rausfinden, ob sich damit noch bessere Ergebnisse erzielen lassen.
7 Anwendung von ML Verfahren: Decision Trees (Entscheidungsbäume)
7.1 Vorhaben
In einem weiteren Schritt wird mit den Entscheidungsbäumen ein erstes Machine Learning-Verfahren angewendet.
Entscheidungsbäume stellen, allgemein gesprochen, Entscheidungen und deren Konsequenzen in einer baumähnlichen Struktur dar. Dabei stellen die Prüfungen die “Astgabeln” oder “Knoten” (nodes) dar, die “Äste” die Entscheidungen der Prüfungen und die “Blätter” des Baumes repräsentieren die Entscheidung des Modells. Entscheidungsbäume können sowohl für Klassifikations- als auch für numerische Vorhersagemodelle verwendet werden.
Grundlegende Entscheidungsbäume unterteilen einen Datensatz in kleinere Gruppen und passen dann für jede Untergruppe ein einfaches Modell (Konstante) an. Leider ist ein einzelnes Baummodell in der Regel sehr instabil und ein schlechter Prädiktor. Durch Bootstrap-Aggregation (Bagging) von Entscheidungsbäumen kann diese Technik jedoch sehr leistungsfähig und effektiv werden. Darüber hinaus bildet dies die grundlegende Grundlage für komplexere baumbasierte Modelle wie Random Forests (“zufällige Wälder”) und sog. gradient boosting machines (“Maschinen zur Erhöhung des Gradienten”).
In diesem Projekt werden nur Entscheidungsbäume und Tuning behandelt.
Die Idee
Es gibt viele Methoden zur Konstruktion von Entscheidungsbäumen, aber eine der ältesten ist der von Breiman et al. entwickelte Klassifizierungs- und Regressionsbaumansatz (CART). (1984). Dieses Projekt konzentriert sich auf den Regressionsteil von CART. Grundlegende Entscheidungs- bzw. Regressionsbäume unterteilen einen Datensatz in kleinere Untergruppen und passen dann für jede Beobachtung in der Untergruppe eine einfache Konstante an. Die Partitionierung wird durch aufeinanderfolgende binäre Partitionen (auch als rekursive Partitionierung bezeichnet) auf der Grundlage der verschiedenen Prädiktoren erreicht. Die vorherzusagende Konstante basiert auf den durchschnittlichen Antwortwerten für alle Beobachtungen, die in diese Untergruppe fallen.
Nehmen wir zum Beispiel an, wir möchten die Umsatz pro Tag einer Bäckereifiliale basierend auf Wochentagen, Jahreszeit, Ferien, … vorhersagen. Alle Beobachtungen gehen durch diesen Baum, werden an einem bestimmten Knoten bewertet und gehen nach links, wenn die Antwort “Ja” lautet, oder nach rechts, wenn die Antwort “Nein” lautet. Alle Beobachtungen mit Samstag oder Sonntag gehen also zum linken Zweig, alle anderen Beobachtungen zum rechten Zweig. Als nächstes wird der linke Zweig weiter nach der Jahreszeit aufgeteilt. Diese Samstag- oder Sonntag-Beobachtungen mit der Jahreszeit Sommer gehen zum linken Zweig über, diejenigen mit Frühling, Herbst oder Winter gehen nach rechts. Und so weiter. Diese Zweige führen abschließend zu Endknoten oder Blättern, die unseren vorhergesagten Umsatz pro Tag enthalten.
Über Splits entscheiden
Erstens ist es wichtig zu erkennen, dass die Partitionierung von Variablen von oben nach unten erfolgt. Dies bedeutet, dass sich eine früher in der Baumstruktur ausgeführte Partition nicht aufgrund späterer Partitionen ändert.
Aber wie werden diese Partitionen hergestellt? Das Modell beginnt mit dem gesamten Datensatz \(S\) und durchsucht jeden einzelnen Wert jeder Eingabevariablen, um den Prädiktor und den Teilungswert zu finden, der die Daten in zwei Regionen unterteilt (\(R_1\) und \(R_2\)) derart, dass die Gesamtsummen der Fehlerquadrate minimiert werden:
\[minimiere(SSE = \sum_{i \epsilon R_1}(y_i-c_1)^2+\sum_{i \epsilon R_2}(y_i-c_2)^2 \tag{1}\]
Nachdem wir die beste Aufteilung gefunden haben, teilen wir die Daten in die beiden resultierenden Regionen auf und wiederholen den Aufteilungsprozess für jede der beiden Regionen. Dieser Vorgang wird fortgesetzt, bis ein Stoppkriterium erreicht ist. Das Ergebnis ist in der Regel ein sehr tiefer, komplexer Baum, der zwar gute Vorhersagen für den Trainingssatz liefert, die Daten jedoch wahrscheinlich überpasst, was zu einer schlechten Leistung bei unsichtbaren Daten führt.
Durch Beschneiden dieser Entscheidungsknoten auf niedrigerer Ebene können wir ein wenig Verzerrung in unser Modell einbringen, die zur Stabilisierung von Vorhersagen beiträgt und dazu neigt, besser auf neue, unsichtbare Daten zu verallgemeinern.
Kostenkomplexitätskriterium
In der Tiefe und Komplexität des Baums muss häufig ein Gleichgewicht erreicht werden, um die Vorhersageleistung für einige unsichtbare Daten zu optimieren. Um dieses Gleichgewicht zu finden, bilden wir normalerweise einen sehr großen Baum, wie im vorherigen Abschnitt definiert, und beschneiden ihn dann, um einen optimalen Teilbaum zu finden. Wir finden den optimalen Teilbaum unter Verwendung eines Kostenkomplexitätsparameters (\(\alpha\)), der unsere Zielfunktion (s. (1)) für die Anzahl der Endknoten des Baumes (\(T\)) “bestraft”:
\[minimiere(SSE+\alpha{|T|}) \tag{2}\]
Für einen gegebenen Wert von \(\alpha\) finden wir den kleinsten beschnittenen Baum mit dem niedrigsten bestraften Fehler. Dabei führen kleinere Strafen tendenziell zu komplexeren Modellen, was zu größeren Bäumen führt, während größere Strafen zu viel kleineren Bäumen führen. Wenn ein Baum größer wird, muss folglich die Verringerung der \(SSE\) größer sein als die Kostenkomplexitätsstrafe. Typischerweise bewerten wir mehrere Modelle über ein Spektrum von \(\alpha\) und verwenden die Kreuzvalidierung, um das optimale \(\alpha\) und damit den optimalen Teilbaum zu identifizieren
Laden notwendiger packages
Für das Vorhaben werden die nachfolgenden packages benötigt und somit geladen. Die meisten dieser packages/Pakete spielen eine unterstützende Rolle, während der Schwerpunkt auf dem rpart-package liegt.
## Warning: package 'rpart' was built under R version 3.6.3
## Warning: package 'rpart.plot' was built under R version 3.6.3
7.2 Datenaufbereitung
Wir arbeiten mit dem vollständigen Datensatz df_voll. Dieser enthält im Zeitraum 01.07.2013 bis 31.07.2019 eine Zeile für jedes Datum und jede Warengruppe. In den Rohdaten fehlende Umsätze sind auf Basis der Vorwochenwerte ergänzt worden. Die Zeilen mit ergänzten Umsätzen sind selektierbar über die Variable Umsatz_NA (= TRUE).
Für unser Vorhaben beschränken wir uns auf die in den Rohdaten vorhandenen Umsätze (Umsatz_NA = FALSE). Und wir schränken die Trainingsdaten später auf den Zeitraum 2015 bis 2017 ein, weil wir oben gesehen hatten, dass die Umsätze in 2014 systematisch höher liegen als in den folgenden Jahren. Die Umsätze des Jahres 2018 dienen uns dann als Testdaten.
Wir erstellen für diesen Abschnitt einen Analysedatensatz df_dt auf Basis von df_voll. Redundante Spalten nehmen wir raus (Wochentag, Monat, Jahreszeit) und entfernen die nicht benötigten Umsatz-Spalten (Umsatz_NA sowie die Umsatz_lag Variablen).
df_dt <- df_voll
# verwende nur originäre Umsatzdaten und grenze den Zeitraum auf 2015 bis 2018 ein
df_dt <- df_dt %>%
filter(Umsatz_NA == FALSE) %>%
filter(Jahr >= 2015 & Jahr <= 2018)
# behalte nur die Spalten, die wir für den DT verwenden wollen
df_dt <- df_dt %>%
dplyr::select(-Wochentag, -Monat, -Jahreszeit, -Umsatz_NA, -Umsatz_lag_1W, -Umsatz_lag_2W, -Umsatz_lag_3W, -Umsatz_lag_4W, -Umsatz_lag)Weiterhin werden fehlende Werte eleminiert.
Für die Trainingsdaten verwenden wir den Zeitraum 2015 bis 2017 und für die Testdaten das Jahr 2018. Die Modellierung erfolgt je Warengruppe, daher teilen wir den Datensatz df_dt auf.
df_dt_train <- df_dt %>% filter(Jahr < 2018)
df_dt_test <- df_dt %>% filter(Jahr == 2018)
df_dt_train_WG1 <- df_dt_train %>% filter(Warengruppe==1)
df_dt_train_WG2 <- df_dt_train %>% filter(Warengruppe==2)
df_dt_train_WG3 <- df_dt_train %>% filter(Warengruppe==3)
df_dt_train_WG4 <- df_dt_train %>% filter(Warengruppe==4)
df_dt_train_WG5 <- df_dt_train %>% filter(Warengruppe==5)
df_dt_test_WG1 <- df_dt_test %>% filter(Warengruppe==1)
df_dt_test_WG2 <- df_dt_test %>% filter(Warengruppe==2)
df_dt_test_WG3 <- df_dt_test %>% filter(Warengruppe==3)
df_dt_test_WG4 <- df_dt_test %>% filter(Warengruppe==4)
df_dt_test_WG5 <- df_dt_test %>% filter(Warengruppe==5)7.3 Grundlegende Implementierung und Tuning
Wir können einen Regressionsbaum mit rpart anpassen und ihn dann mit rpart.plot visualisieren. Der Anpassungsprozess und die visuelle Ausgabe von Regressionsbäumen und Klassifizierungsbäumen sind sehr ähnlich. Beide verwenden die Formelmethode zum Ausdrücken des Modells (ähnlich wie lm). Wenn wir jedoch einen Regressionsbaum anpassen, müssen wir method = "anova" setzen. Standardmäßig errät rpart auf intelligente Weise, welche Methode anzuwenden ist. Es wird jedoch empfohlen, die Methode aus Gründen der Reproduzierbarkeit explizit festzulegen, was wir hier auch tun.
Grundlegende Implementierung - Warengruppe 1
Wir beginnen mit Warengruppe 1:
# Warengruppe 1
dt1_WG1 <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG1,
method = "anova"
)
dt1_WG1## n= 1061
##
## node), split, n, deviance, yval
## * denotes terminal node
##
## 1) root 1061 1563625.00 115.84770
## 2) Wochentag_c=Sonntag 152 83154.48 70.13539 *
## 3) Wochentag_c=Dienstag,Donnerstag,Freitag,Mittwoch,Montag,Samstag 909 1109737.00 123.49150
## 6) Monat_c=Dezember,Februar,Januar,Mai,März,November 449 411981.10 112.89780
## 12) Wochentag_c=Dienstag,Mittwoch 153 87761.02 102.87250 *
## 13) Wochentag_c=Donnerstag,Freitag,Montag,Samstag 296 300894.50 118.07970
## 26) Monat_c=Februar,Januar,November 147 78542.65 111.16610 *
## 27) Monat_c=Dezember,Mai,März 149 208393.70 124.90050
## 54) Herbst>=0.5 34 15459.65 106.30530 *
## 55) Herbst< 0.5 115 177701.60 130.39820
## 110) Monat_c=Mai,März 100 90925.75 123.84400 *
## 111) Monat_c=Dezember 15 53842.03 174.09270 *
## 7) Monat_c=April,August,Juli,Juni,Oktober,September 460 598180.50 133.83200
## 14) Wochentag_c=Dienstag,Freitag,Mittwoch,Montag 303 238193.20 125.72070
## 28) SommerferienSH< 0.5 232 165626.30 120.53570
## 56) Wochentag_c=Dienstag,Mittwoch 116 49095.09 111.53700 *
## 57) Wochentag_c=Freitag,Montag 116 97744.38 129.53450 *
## 29) SommerferienSH>=0.5 71 45950.02 142.66300 *
## 15) Wochentag_c=Donnerstag,Samstag 157 301577.80 149.48630
## 30) Windgeschwindigkeit< 17.5 148 170217.30 145.88320
## 60) SommerferienSH< 0.5 112 103566.60 138.44150 *
## 61) SommerferienSH>=0.5 36 41152.06 169.03500 *
## 31) Windgeschwindigkeit>=17.5 9 97842.50 208.73780 *
Sobald wir unser Modell angepasst haben, können wir einen Blick auf den dt1_WG1-Output werfen. Dieser erklärt die Schritte der Teilung: Wir beginnen bspw. mit 1061 Beobachtungen am Wurzelknoten (ganz am Anfang) und die erste Variable, die zur Teilung verwendet wird (also die erste Variable, die eine Reduzierung der SSE optimiert), ist der Wochentag Sonntag. Wir sehen, dass am ersten Knoten alle Beobachtungen mit Wochentag_c = Sonntag zum zweiten Zweig gehen. Die Gesamtzahl der Beobachtungen, die diesem Zweig folgen (152), der durchschnittliche Umsatz (70,14) und der SSE (83154.48) sind aufgeführt.
Wenn man nach dem 3. Zweig sucht, sieht man, dass 909 Beobachtungen mit Wochentag_c = Dienstag, Donnerstag, Freitag, Mittwoch, Montag, Samstag diesem Zweig folgen und ihre durchschnittlichen Umsätze 123.49€ betragen und der SSE hier 1109737.00 beträgt.
Grundsätzlich sagt uns dies, dass die wichtigste Variable, die anfangs den größten Rückgang der SSE aufweist, der Wochentag ist, wobei die Umsätze sonntags in der Warengruppe Brot um > 40% geringer sind als an den anderen Tagen der Woche.
Wir können unser Modell mit rpart.plot visualisieren. rpart.plot bietet viele Plotoptionen, auf die wir an dieser Stelle nicht weiter eingehen werden. Im Standard-Plot werden jedoch der Prozentsatz der Daten angezeigt, die auf diesen Knoten fallen, und der durchschnittliche Umsatz für diesen Zweig.
## Warning: package 'partykit' was built under R version 3.6.3
## Loading required package: grid
## Loading required package: libcoin
## Warning: package 'libcoin' was built under R version 3.6.3
## Loading required package: mvtnorm
Man kann feststellen, dass dieser Baum 11 interne Knoten enthält, was zu 12 Endknoten führt. Grundsätzlich partitioniert dieser Baum in 11 Variablen, um sein Modell zu erstellen. Es gibt jedoch 28 Variablen in df_dt_train_WG1. Also was ist passiert?
Hinter den Kulissen wendet rpart automatisch einen Bereich von Kostenkomplexität an (\(\alpha\)-Werte zum Beschneiden des Baums). Um den Fehler für jeden \(\alpha\)-Wert zu vergleichen, führt rpart eine 10-fache Kreuzvalidierung durch, sodass der mit einem bestimmten \(\alpha\)-Wert verbundene Fehler berechnet wird.
In diesem Beispiel finden wir abnehmende Renditen nach 12 Endknoten, wie in der Grafik dargestellt (y-Achse ist Kreuzvalidierungsfehler, untere x-Achse ist Kostenkomplexitätswert (\(\alpha\)), obere x-Achse ist die Anzahl von Endknoten (Baumgröße = | T |)). Die gestrichelte Linie, die zwischen den Punkten | T | = 3 und 4 verläuft, deutet darauf hin, dass auch ein kleiner Baum gewählt werden kann. Breiman et al. (1984) schlugen vor, dass es in der Praxis üblich ist, den kleinsten Baum innerhalb von 1 Standardabweichung des minimalen Kreuzvalidierungsfehlers zu verwenden (auch bekannt als 1-SE-Regel). Daher könnten wir auch einen Baum mit 3 oder 4 Endknoten verwenden und vernünftigerweise erwarten, dass innerhalb einer kleinen Fehlergrenze ähnliche Ergebnisse erzielt werden.
## CP nsplit rel error xerror xstd
## 1 0.23709823 0 1.0000000 1.0007520 0.08063025
## 2 0.06368273 1 0.7629018 0.7638485 0.07379301
## 3 0.03735521 2 0.6992190 0.7371015 0.07603333
## 4 0.02143612 3 0.6618638 0.7079574 0.07291012
## 5 0.01702257 4 0.6404277 0.6958333 0.07146426
## 6 0.01630738 5 0.6234051 0.7045073 0.07216297
## 7 0.01491763 6 0.6070978 0.7012062 0.07146606
## 8 0.01324367 7 0.5921801 0.6996919 0.07152802
## 9 0.01201489 10 0.5524491 0.6950991 0.07144299
## 10 0.01000000 11 0.5404342 0.6794592 0.07105814
Tuning - Warengruppe 1
Neben dem Kostenkomplexität (\(\alpha\))-Parameter ist es auch üblich folgende Parameter anzupassen:
minsplit: Die Mindestanzahl von Datenpunkten, die erforderlich sind, um eine Teilung zu versuchen, bevor ein Endknoten erstellt werden muss. Der Standardwert ist 20. Wenn man diesen Wert verkleinert, können Endknoten, die möglicherweise nur eine Handvoll Beobachtungen enthalten, erstellt werden um den vorhergesagten Wert zu prognostizieren.maxdepth: Die maximale Anzahl interner Knoten zwischen dem Wurzelknoten und den Endknoten. Der Standardwert ist 30, was ziemlich liberal ist und das Bauen ziemlich großer Bäume ermöglicht.
rpart verwendet ein spezielles Steuer- bzw. Kontrollargument, bei dem eine Liste von Hyperparameterwerten bereitgestellt wird. Wenn wir beispielsweise ein Modell mit minsplit = 20 und maxdepth = 12 bewerten möchten, können wir Folgendes ausführen:
dt2_WG1 <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG1,
method = "anova",
control = list(minsplit = 20, maxdepth = 12, xval = 10)
)
dt2_WG1$cptable## CP nsplit rel error xerror xstd
## 1 0.23709823 0 1.0000000 1.0025616 0.08072507
## 2 0.06368273 1 0.7629018 0.7655185 0.07390815
## 3 0.03735521 2 0.6992190 0.7253093 0.07566630
## 4 0.02143612 3 0.6618638 0.6998751 0.07026250
## 5 0.01702257 4 0.6404277 0.7088119 0.07112063
## 6 0.01630738 5 0.6234051 0.6965625 0.07025804
## 7 0.01491763 6 0.6070978 0.6874196 0.07016375
## 8 0.01324367 7 0.5921801 0.6874196 0.07016375
## 9 0.01201489 10 0.5524491 0.6820625 0.06975680
## 10 0.01000000 11 0.5404342 0.6594922 0.06764893
Obwohl dieser Ansatz nützlich ist, müssen mehrere Modelle manuell bewertet werden. Besser ist es insofern eine Rastersuche durchzuführen, um automatisch nach einer Reihe unterschiedlich abgestimmter Modelle zu suchen, um die optimale Hyperparametereinstellung zu ermitteln.
Um eine Rastersuche durchzuführen, erstellen wir zuerst unser Hyperparameter-Raster. In diesem Beispiel suchen wir einen Bereich von minsplit von 5 bis 150 und variiere die maximale Tiefe von 8 bis 15 (da unser ursprüngliches Modell eine optimale Tiefe von 12 gefunden hat). Das Ergebnis sind 1168 verschiedene Kombinationen, für die 1168 verschiedene Modelle erforderlich sind.
## minsplit maxdepth
## 1 5 8
## 2 6 8
## 3 7 8
## 4 8 8
## 5 9 8
## 6 10 8
## minsplit maxdepth
## 1 5 8
## 2 6 8
## 3 7 8
## 4 8 8
## 5 9 8
## 6 10 8
# Gesamtanzahl aller Kombinationen
nrow(hyper_grid)## [1] 1168
Um die Modellierung zu automatisieren, richten wir einfach eine for-Schleife ein und durchlaufen jede Kombination aus minsplit und maxdepth. Wir speichern jedes Modell in einem eigenen Listenelement.
models <- list()
for (i in 1:nrow(hyper_grid)) {
# minsplit, maxdepth values in Zeile i
minsplit <- hyper_grid$minsplit[i]
maxdepth <- hyper_grid$maxdepth[i]
# Trainiere ein modell und speichere es in der Liste
models[[i]] <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG1,
method = "anova",
control = list(minsplit = minsplit, maxdepth = maxdepth)
)
}Wir können jetzt eine Funktion erstellen, um den minimalen Fehler zu extrahieren, der mit dem α-Wert der optimalen Kostenkomplexität für jedes Modell verbunden ist.
# Funktion um den optimalen cp zu erreichen
get_cp <- function(x) {
min <- which.min(x$cptable[, "xerror"])
cp <- x$cptable[min, "CP"]
}
# Funktion um den minimalen Fehler zu erhalten
get_min_error <- function(x) {
min <- which.min(x$cptable[, "xerror"])
xerror <- x$cptable[min, "xerror"]
}
hyper_grid %>%
mutate(
cp = purrr::map_dbl(models, get_cp),
error = purrr::map_dbl(models, get_min_error)
) %>%
arrange(error) %>%
top_n(-5, wt = error)## minsplit maxdepth cp error
## 1 57 14 0.01 0.6034856
## 2 69 14 0.01 0.6047776
## 3 71 8 0.01 0.6077570
## 4 36 10 0.01 0.6107883
## 5 47 13 0.01 0.6114659
## minsplit maxdepth cp error
## 51 14 0.01 0.6055641
## 70 10 0.01 0.6061298
## 9 14 0.01 0.6149394
## 81 8 0.01 0.6154432
## 92 11 0.01 0.6165628 Es ist erkennbar, dass das optimale Modell eine leichte Verbesserung gegenüber unserem früheren Modell darstellt (xerror von 0.599 gegenüber 0.643).
Wenn die Ergebnisse zufriedenstellend sind, kann dieses endgültige optimale Modell angewendet werden und auf dem Testsatz vorhersagen.
optimal_tree_WG1 <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG1,
method = "anova",
control = list(minsplit = 51, maxdepth = 14, cp = 0.01)
)
pred <- predict(optimal_tree_WG1, newdata = df_dt_test_WG1)
RMSE(pred = pred, obs = df_dt_test_WG1$Umsatz)## [1] 39.77669
Der endgültige RMSE beträgt 39.78, was darauf hindeutet, dass unsere prognostizierten Umsätze im Durchschnitt etwa 39.78 € vom tatsächlichen Umsatz abweichen.
Um das Modell abschließend mit den anderen vergleichen zu können, wird eine Tabelle mit den zu untersuchenden Kennzahlen erstellt:
# Hinzufügen der Ergebnisse
df_dt_test_WG1 <- df_dt_test_WG1 %>%
mutate(predicted = pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_dt_test_WG1 <- df_dt_test_WG1 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_dt_test_WG1 <- df_dt_test_WG1 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_dt_test_WG1 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "optimaltree_WG1")
# füge die Kennzahlen nun an die Vergleichstabelle
dt_vgl_kennz <- temp
dt_vgl_kennz## # A tibble: 1 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 27.7 -5.68 20.9 20.9 1582. 39.8 30.1
## # ... with 1 more variable: Modell <chr>
Grundlegende Implementierung - Warengruppe 2
Wir führen unsere Modellierung fort mit Warengruppe 2:
# Warengruppe 2
dt1_WG2 <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG2,
method = "anova"
)
dt1_WG2## n= 1061
##
## node), split, n, deviance, yval
## * denotes terminal node
##
## 1) root 1061 15929630.00 381.1674
## 2) Monat_c=April,Dezember,Februar,Januar,Juni,Mai,März,November,Oktober,September 880 9116888.00 349.3631
## 4) Wochenende< 0.5 627 3462522.00 309.6481
## 8) Monat_c=Dezember,Februar,Januar,März,November 311 974238.00 266.7023 *
## 9) Monat_c=April,Juni,Mai,Oktober,September 316 1350177.00 351.9144
## 18) Feiertag< 0.5 306 873680.80 345.4458 *
## 19) Feiertag>=0.5 10 71891.38 549.8540 *
## 5) Wochenende>=0.5 253 2214517.00 447.7873
## 10) Monat_c=April,Dezember,Februar,Januar,März,November,Oktober 177 1463866.00 423.9788
## 20) Wochentag_c=Samstag 89 631877.70 382.1070 *
## 21) Wochentag_c=Sonntag 88 518136.10 466.3265 *
## 11) Monat_c=Juni,Mai,September 76 416653.20 503.2361
## 22) KielerWoche< 0.5 64 170999.50 483.3930 *
## 23) KielerWoche>=0.5 12 86054.56 609.0658 *
## 3) Monat_c=August,Juli 181 1594924.00 535.7956
## 6) Wochentag_c=Dienstag,Donnerstag,Freitag,Mittwoch,Montag 128 788213.50 502.3090
## 12) SommerferienNRW< 0.5 36 139970.00 438.1064 *
## 13) SommerferienNRW>=0.5 92 441786.40 527.4317
## 26) SommerferienHE< 0.5 35 128025.80 472.8897 *
## 27) SommerferienHE>=0.5 57 145708.70 560.9225 *
## 7) Wochentag_c=Samstag,Sonntag 53 316529.90 616.6691 *
Sobald wir unser Modell angepasst haben, können wir einen Blick auf den dt1_WG2-Output werfen. Wir beginnen wieder mit 1061 Beobachtungen am Wurzelknoten (ganz am Anfang) und die erste Variable, die zur Teilung verwendet wird (also die erste Variable, die eine Reduzierung der SSE optimiert), ist bei dieser Warengruppe der Monat (Monat_c=April,Dezember,Februar,Januar,Juni,Mai,März,November,Oktober,September). Wir sehen, dass am ersten Knoten alle Beobachtungen mit Monat_c=April,Dezember,Februar,Januar,Juni,Mai,März,November,Oktober,September zum zweiten Zweig gehen. Die Gesamtzahl der Beobachtungen, die diesem Zweig folgen (880), der durchschnittliche Umsatz (266.70) und der SSE (974238.00) sind aufgeführt.
Wenn man nach dem 3. Zweig sucht, sieht man, dass 181 Beobachtungen mit Monat_c=August,Juli diesem Zweig folgen und ihre durchschnittlichen Umsätze 535.80€ betragen und der SSE hier 1594924.00 beträgt.
Grundsätzlich sagt uns dies, dass die wichtigste Variable, die anfangs den größten Rückgang der SSE aufweist, der Monat ist, wobei die durchschnittlichen Umsätze im August und Juli in der Warengruppe Brötchen um > 100% höher sind als in den Monaten April, Dezember, Februar, Januar, Juni, Mai, März, November, Oktober, September.
Wir visualisieren unser Modell mit erneut rpart.plot.
Man kann feststellen, dass dieser Baum 10 interne Knoten enthält, was zu 11 Endknoten führt.
Die gestrichelte Linie, die zwischen den Punkten | T | = 8 und 9 verläuft, deutet abermals darauf hin, dass auch ein kleiner Baum gewählt werden kann. Wir könnten nach der 1-SE-Regel auch einen Baum mit 8 oder 9 Endknoten verwenden und vernünftigerweise erwarten, dass innerhalb einer kleinen Fehlergrenze ähnliche Ergebnisse erzielt werden.
## CP nsplit rel error xerror xstd
## 1 0.32755436 0 1.0000000 1.0016257 0.04113458
## 2 0.21594023 1 0.6724456 0.7016596 0.03382816
## 3 0.07144593 2 0.4565054 0.4828927 0.02666755
## 4 0.03077162 3 0.3850595 0.3984642 0.02693381
## 5 0.02539950 4 0.3542879 0.3670658 0.02635521
## 6 0.02096710 5 0.3288884 0.3533777 0.02575326
## 7 0.01970240 6 0.3079213 0.3469551 0.02575319
## 8 0.01296057 7 0.2882189 0.3228774 0.02442165
## 9 0.01054964 8 0.2752583 0.3127874 0.02431265
## 10 0.01001901 9 0.2647086 0.3066701 0.02462897
## 11 0.01000000 10 0.2546896 0.3067664 0.02462739
Tuning - Warengruppe 2
Neben dem Kostenkomplexität (α)-Parameter ist es auch üblich folgende Parameter anzupassen:
minsplit: Die Mindestanzahl von Datenpunkten, die erforderlich sind, um eine Teilung zu versuchen, bevor ein Endknoten erstellt werden muss. Der Standardwert ist 20. Wenn man diesen Wert verkleinert, können Endknoten, die möglicherweise nur eine Handvoll Beobachtungen enthalten, erstellt werden um den vorhergesagten Wert zu prognostizieren.maxdepth: Die maximale Anzahl interner Knoten zwischen dem Wurzelknoten und den Endknoten. Der Standardwert ist 30, was ziemlich liberal ist und das Bauen ziemlich großer Bäume ermöglicht.
rpart verwendet ein spezielles Steuer- bzw. Kontrollargument, bei dem eine Liste von Hyperparameterwerten bereitgestellt wird. Wenn wir beispielsweise ein Modell mit minsplit = 20 und maxdepth = 12 bewerten möchten, können wir Folgendes ausführen:
dt2_WG2 <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG2,
method = "anova",
control = list(minsplit = 20, maxdepth = 12, xval = 10)
)
dt2_WG2$cptable## CP nsplit rel error xerror xstd
## 1 0.32755436 0 1.0000000 1.0023766 0.04121167
## 2 0.21594023 1 0.6724456 0.6861032 0.03367905
## 3 0.07144593 2 0.4565054 0.4697980 0.02656684
## 4 0.03077162 3 0.3850595 0.3937367 0.02533732
## 5 0.02539950 4 0.3542879 0.3572804 0.02426641
## 6 0.02096710 5 0.3288884 0.3445793 0.02379213
## 7 0.01970240 6 0.3079213 0.3310022 0.02132162
## 8 0.01296057 7 0.2882189 0.3105624 0.02098032
## 9 0.01054964 8 0.2752583 0.2948911 0.01993243
## 10 0.01001901 9 0.2647086 0.2899849 0.01997785
## 11 0.01000000 10 0.2546896 0.2900870 0.01998015
Obwohl dieser Ansatz nützlich ist, müssen mehrere Modelle manuell bewertet werden. Besser ist es insofern eine Rastersuche durchzuführen, um automatisch nach einer Reihe unterschiedlich abgestimmter Modelle zu suchen, um die optimale Hyperparametereinstellung zu ermitteln.
Um eine Rastersuche durchzuführen, erstellen wir zuerst unser Hyperparameter-Raster. In diesem Beispiel suchen wir einen Bereich von minsplit von 5 bis 150 und variiere die maximale Tiefe von 8 bis 15 (da unser ursprüngliches Modell eine optimale Tiefe von 11 gefunden hat). Das Ergebnis sind 1168 verschiedene Kombinationen, für die 1168 verschiedene Modelle erforderlich sind.
## minsplit maxdepth
## 1 5 8
## 2 6 8
## 3 7 8
## 4 8 8
## 5 9 8
## 6 10 8
## [1] 1168
Um die Modellierung zu automatisieren, richten wir einfach eine for-Schleife ein und durchlaufen jede Kombination aus minsplit und maxdepth. Wir speichern jedes Modell in einem eigenen Listenelement.
models <- list()
for (i in 1:nrow(hyper_grid)) {
# minsplit, maxdepth values in Zeile i
minsplit <- hyper_grid$minsplit[i]
maxdepth <- hyper_grid$maxdepth[i]
# Trainiere ein Model und speichere es in der Liste
models[[i]] <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG2,
method = "anova",
control = list(minsplit = minsplit, maxdepth = maxdepth)
)
}Wir erstellen erneut eine Funktion, um den minimalen Fehler zu extrahieren, der mit dem α-Wert der optimalen Kostenkomplexität für jedes Modell verbunden ist.
# Funktion um den optimalen cp zu erreichen
get_cp <- function(x) {
min <- which.min(x$cptable[, "xerror"])
cp <- x$cptable[min, "CP"]
}
# Funktion um den minimalen Fehler zu erhalten
get_min_error <- function(x) {
min <- which.min(x$cptable[, "xerror"])
xerror <- x$cptable[min, "xerror"]
}
hyper_grid %>%
mutate(
cp = purrr::map_dbl(models, get_cp),
error = purrr::map_dbl(models, get_min_error)
) %>%
arrange(error) %>%
top_n(-5, wt = error)## minsplit maxdepth cp error
## 1 35 14 0.01 0.2704591
## 2 51 9 0.01 0.2765698
## 3 60 15 0.01 0.2766250
## 4 17 8 0.01 0.2768709
## 5 10 13 0.01 0.2770677
Es ist erkennbar, dass das optimale Modell eine leichte Verbesserung gegenüber unserem früheren Modell darstellt (xerror von 0.2720379 gegenüber 0.2886208).
Wenn die Ergebnisse zufriedenstellend sind, kann dieses endgültige optimale Modell angewendet werden und auf dem Testsatz vorhersagen.
optimal_tree_WG2 <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG2,
method = "anova",
control = list(minsplit = 10, maxdepth = 10, cp = 0.01)
)
pred <- predict(optimal_tree_WG2, newdata = df_dt_test_WG2)
RMSE(pred = pred, obs = df_dt_test_WG2$Umsatz)## [1] 65.51296
Der endgültige RMSE beträgt 65.51, was darauf hindeutet, dass unsere prognostizierten Umsätze im Durchschnitt etwa 65.51 € vom tatsächlichen Umsatz abweichen.
# Hinzufügen der Ergebnisse
df_dt_test_WG2 <- df_dt_test_WG2 %>%
mutate(predicted = pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_dt_test_WG2 <- df_dt_test_WG2 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_dt_test_WG2 <- df_dt_test_WG2 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_dt_test_WG2 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "optimaltree_WG2")
# füge die Kennzahlen nun an die Vergleichstabelle
dt_vgl_kennz <- rbind(dt_vgl_kennz, temp)
dt_vgl_kennz## # A tibble: 2 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 27.7 -5.68 20.9 20.9 1582. 39.8 30.1
## 2 346 130413. 377. 50.5 4.25 14.0 13.4 4292. 65.5 17.4
## # ... with 1 more variable: Modell <chr>
Grundlegende Implementierung - Warengruppe 3
Nachfolgend wird Warengruppe 3 behandelt.
# Warengruppe 3
dt1_WG3 <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG3,
method = "anova"
)
dt1_WG3## n= 1061
##
## node), split, n, deviance, yval
## * denotes terminal node
##
## 1) root 1061 4688829.00 149.55630
## 2) Monat_c=April,Dezember,Februar,Januar,Juni,Mai,März,November,Oktober,September 880 1984950.00 129.36170
## 4) Wochentag_c=Dienstag,Donnerstag,Freitag,Mittwoch,Montag 627 794490.20 113.85110
## 8) Monat_c=Dezember,Februar,Januar,März,November 311 175179.10 93.59717 *
## 9) Monat_c=April,Juni,Mai,Oktober,September 316 366170.70 133.78470
## 18) Feiertag< 0.5 306 274367.60 130.93840 *
## 19) Feiertag>=0.5 10 13469.92 220.87900 *
## 5) Wochentag_c=Samstag,Sonntag 253 665791.90 167.80090
## 10) Monat_c=Dezember,Februar,Januar,März,November 122 129148.10 134.40700 *
## 11) Monat_c=April,Juni,Mai,Oktober,September 131 273892.80 198.90060
## 22) Temperatur< 17.05 89 133836.20 183.32810 *
## 23) Temperatur>=17.05 42 72738.80 231.89950 *
## 3) Monat_c=August,Juli 181 600141.40 247.74020
## 6) SommerferienHE< 0.5 69 139217.20 213.65300
## 12) Wochentag_c=Dienstag,Donnerstag,Freitag,Mittwoch,Montag 45 62313.36 193.50270 *
## 13) Wochentag_c=Samstag,Sonntag 24 24372.70 251.43500 *
## 7) SommerferienHE>=0.5 112 331358.00 268.74040
## 14) SommerferienNRW< 0.5 36 71561.49 225.35670 *
## 15) SommerferienNRW>=0.5 76 159943.80 289.29050 *
Der dt1_WG3-Output beginnt wieder mit 1061 Beobachtungen am Wurzelknoten (ganz am Anfang) und die erste Variable, die zur Teilung verwendet wird (also die erste Variable, die eine Reduzierung der SSE optimiert), ist bei dieser Warengruppe der Monat (Monat_c=April,Dezember,Februar,Januar,Juni,Mai,März,November,Oktober,September). Wir sehen, dass am ersten Knoten alle Beobachtungen mit Monat_c=April,Dezember,Februar,Januar,Juni,Mai,März,November,Oktober,September zum zweiten Zweig gehen. Die Gesamtzahl der Beobachtungen, die diesem Zweig folgen (880), der durchschnittliche Umsatz (266.70) und der SSE (974238.00) sind aufgeführt.
Wenn man nach dem 3. Zweig sucht, sieht man, dass 181 Beobachtungen mit Monat_c=August,Juli diesem Zweig folgen und ihre durchschnittlichen Umsätze 535.80€ betragen und der SSE hier 1594924.00 beträgt.
Grundsätzlich sagt uns dies, dass die wichtigste Variable, die anfangs den größten Rückgang der SSE aufweist, der Monat ist, wobei die durchschnittlichen Umsätze im August und Juli in der Warengruppe Brötchen um > 100% höher sind als in den Monaten April, Dezember, Februar, Januar, Juni, Mai, März, November, Oktober, September.
Wir visualisieren unser Modell mit erneut rpart.plot.
Man kann feststellen, dass dieser Baum 9 interne Knoten enthält, was zu 10 Endknoten führt.
Die gestrichelte Linie, die durch den Punkt | T | = 9 verläuft, deutet abermals darauf hin, dass auch ein kleiner Baum gewählt werden kann. Wir könnten nach der 1-SE-Regel auch einen Baum mit 9 Endknoten verwenden und vernünftigerweise erwarten, dass innerhalb einer kleinen Fehlergrenze ähnliche Ergebnisse erzielt werden.
## CP nsplit rel error xerror xstd
## 1 0.44867020 0 1.0000000 1.0013153 0.04972720
## 2 0.11189740 1 0.5513298 0.5540031 0.03008239
## 3 0.05603766 2 0.4394324 0.4331636 0.02310000
## 4 0.05398798 3 0.3833947 0.4166567 0.02300617
## 5 0.02763295 4 0.3294068 0.3461249 0.02059550
## 6 0.02129588 5 0.3017738 0.3183166 0.01976822
## 7 0.01670633 6 0.2804779 0.2985020 0.01882963
## 8 0.01435706 7 0.2637716 0.2880086 0.01829802
## 9 0.01120346 8 0.2494145 0.2798055 0.01819912
## 10 0.01000000 9 0.2382111 0.2567348 0.01597194
Tuning - Warengruppe 3
Neben dem Kostenkomplexität (α)-Parameter ist es auch üblich folgende Parameter anzupassen:
minsplit: Die Mindestanzahl von Datenpunkten, die erforderlich sind, um eine Teilung zu versuchen, bevor ein Endknoten erstellt werden muss. Der Standardwert ist 20. Wenn man diesen Wert verkleinert, können Endknoten, die möglicherweise nur eine Handvoll Beobachtungen enthalten, erstellt werden um den vorhergesagten Wert zu prognostizieren.maxdepth: Die maximale Anzahl interner Knoten zwischen dem Wurzelknoten und den Endknoten. Der Standardwert ist 30, was ziemlich liberal ist und das Bauen ziemlich großer Bäume ermöglicht.
rpart verwendet ein spezielles Steuer- bzw. Kontrollargument, bei dem eine Liste von Hyperparameterwerten bereitgestellt wird. Wenn wir beispielsweise ein Modell mit minsplit = 20 und maxdepth = 12 bewerten möchten, können wir Folgendes ausführen:
dt2_WG3 <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG3,
method = "anova",
control = list(minsplit = 20, maxdepth = 12, xval = 10)
)
dt2_WG3$cptable## CP nsplit rel error xerror xstd
## 1 0.44867020 0 1.0000000 1.0016652 0.04977874
## 2 0.11189740 1 0.5513298 0.5543194 0.03011698
## 3 0.05603766 2 0.4394324 0.4431994 0.02387733
## 4 0.05398798 3 0.3833947 0.4120083 0.02243600
## 5 0.02763295 4 0.3294068 0.3397735 0.02167013
## 6 0.02129588 5 0.3017738 0.3312043 0.02109276
## 7 0.01670633 6 0.2804779 0.3115692 0.02054627
## 8 0.01435706 7 0.2637716 0.2946474 0.01952385
## 9 0.01120346 8 0.2494145 0.2749115 0.01830800
## 10 0.01000000 9 0.2382111 0.2581206 0.01624700
Obwohl dieser Ansatz nützlich ist, müssen mehrere Modelle manuell bewertet werden. Besser ist es insofern eine Rastersuche durchzuführen, um automatisch nach einer Reihe unterschiedlich abgestimmter Modelle zu suchen, um die optimale Hyperparametereinstellung zu ermitteln.
Um eine Rastersuche durchzuführen, erstellen wir zuerst unser Hyperparameter-Raster. In diesem Beispiel suchen wir einen Bereich von minsplit von 5 bis 150 und variiere die maximale Tiefe von 8 bis 15 (da unser ursprüngliches Modell eine optimale Tiefe von 11 gefunden hat). Das Ergebnis sind 1168 verschiedene Kombinationen, für die 1168 verschiedene Modelle erforderlich sind.
## minsplit maxdepth
## 1 5 8
## 2 6 8
## 3 7 8
## 4 8 8
## 5 9 8
## 6 10 8
## [1] 1168
Um die Modellierung zu automatisieren, richten wir einfach eine for-Schleife ein und durchlaufen jede Kombination aus minsplit und maxdepth. Wir speichern jedes Modell in einem eigenen Listenelement.
models <- list()
for (i in 1:nrow(hyper_grid)) {
# minsplit, maxdepth values in Zeile i
minsplit <- hyper_grid$minsplit[i]
maxdepth <- hyper_grid$maxdepth[i]
# Trainiere ein Modell und speichere es in der Liste
models[[i]] <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG3,
method = "anova",
control = list(minsplit = minsplit, maxdepth = maxdepth)
)
}Wir erstellen erneut eine Funktion, um den minimalen Fehler zu extrahieren, der mit dem α-Wert der optimalen Kostenkomplexität für jedes Modell verbunden ist.
# Funktion um den optimalen cp zu erreichen
get_cp <- function(x) {
min <- which.min(x$cptable[, "xerror"])
cp <- x$cptable[min, "CP"]
}
# Funktion um den minimalen Fehler zu erhalten
get_min_error <- function(x) {
min <- which.min(x$cptable[, "xerror"])
xerror <- x$cptable[min, "xerror"]
}
hyper_grid %>%
mutate(
cp = purrr::map_dbl(models, get_cp),
error = purrr::map_dbl(models, get_min_error)
) %>%
arrange(error) %>%
top_n(-5, wt = error)## minsplit maxdepth cp error
## 1 42 10 0.01 0.2450648
## 2 33 10 0.01 0.2480637
## 3 44 8 0.01 0.2490951
## 4 9 11 0.01 0.2493799
## 5 15 14 0.01 0.2495035
Es ist erkennbar, dass das optimale Modell eine leichte Verbesserung gegenüber unserem früheren Modell darstellt (xerror von 0.2488002 gegenüber 0.2652715).
Wenn die Ergebnisse zufriedenstellend sind, kann dieses endgültige optimale Modell angewendet werden und auf dem Testsatz vorhersagen.
optimal_tree_WG3 <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG3,
method = "anova",
control = list(minsplit = 37, maxdepth = 13, cp = 0.01)
)
pred <- predict(optimal_tree_WG3, newdata = df_dt_test_WG3)
RMSE(pred = pred, obs = df_dt_test_WG3$Umsatz)## [1] 50.81046
Der endgültige RMSE beträgt 50.81, was darauf hindeutet, dass unsere prognostizierten Umsätze im Durchschnitt etwa 50.81 € vom tatsächlichen Umsatz abweichen.
# Hinzufügen der Ergebnisse
df_dt_test_WG3 <- df_dt_test_WG3 %>%
mutate(predicted = pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_dt_test_WG3 <- df_dt_test_WG3 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_dt_test_WG3 <- df_dt_test_WG3 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_dt_test_WG3 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "optimaltree_WG3")
# füge die Kennzahlen nun an die Vergleichstabelle
dt_vgl_kennz <- rbind(dt_vgl_kennz, temp)
dt_vgl_kennz## # A tibble: 3 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 27.7 -5.68 20.9 20.9 1582. 39.8 30.1
## 2 346 130413. 377. 50.5 4.25 14.0 13.4 4292. 65.5 17.4
## 3 346 59316. 171. 36.1 -7.43 19.7 21.0 2582. 50.8 29.6
## # ... with 1 more variable: Modell <chr>
Grundlegende Implementierung - Warengruppe 4
Da ganze Procedere wird nun auf Warengruppe 4 angewendet.
# Warengruppe 4
dt1_WG4 <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG4,
method = "anova"
)
dt1_WG4## n= 1047
##
## node), split, n, deviance, yval
## * denotes terminal node
##
## 1) root 1047 1285575.000 88.63587
## 2) Wochentag_c=Dienstag,Donnerstag,Freitag,Mittwoch,Montag,Samstag 895 632802.600 81.13245
## 4) Monat_c=April,Dezember,Januar,Juli,Juni,Mai,März,November,Oktober,September 743 332338.500 76.89122
## 8) Feiertag< 0.5 730 269455.300 75.96748 *
## 9) Feiertag>=0.5 13 27281.310 128.76310 *
## 5) Monat_c=August,Februar 152 221768.500 101.86420
## 10) Datum>=16852 84 62037.990 90.48571 *
## 11) Datum< 16852 68 135420.600 115.92000
## 22) Datum< 16832.5 51 61072.870 100.49370
## 44) Datum>=16488 33 15123.660 83.02606 *
## 45) Datum< 16488 18 17420.550 132.51780 *
## 23) Datum>=16832.5 17 25801.840 162.19880 *
## 3) Wochentag_c=Sonntag 152 305680.200 132.81720
## 6) Monat_c=April,August,Dezember,Januar,Juli,Juni,Mai,März,November,Oktober,September 140 179885.100 125.92110
## 12) Monat_c=Juli,Juni 26 18393.320 99.25923 *
## 13) Monat_c=April,August,Dezember,Januar,Mai,März,November,Oktober,September 114 138794.300 132.00180
## 26) Datum>=17475 8 6562.069 90.20625 *
## 27) Datum< 17475 106 117202.500 135.15620 *
## 7) Monat_c=Februar 12 41460.560 213.27250 *
Der dt1_WG4-Output beginnt mit 1047 Beobachtungen am Wurzelknoten (ganz am Anfang) und die erste Variable, die zur Teilung verwendet wird (also die erste Variable, die eine Reduzierung der SSE optimiert), ist bei dieser Warengruppe der Wochentag (Wochentag_c=Dienstag,Donnerstag,Freitag,Mittwoch,Montag,Samstag). Wir sehen, dass am ersten Knoten alle Beobachtungen mit Wochentag_c=Dienstag,Donnerstag,Freitag,Mittwoch,Montag,Samstag zum zweiten Zweig gehen. Die Gesamtzahl der Beobachtungen, die diesem Zweig folgen (895), der durchschnittliche Umsatz (81.13) und der SSE (632802.600) sind aufgeführt.
Wenn man nach dem 3. Zweig sucht, sieht man, dass 152 Beobachtungen mit 3) Wochentag_c=Sonntag diesem Zweig folgen und ihre durchschnittlichen Umsätze 132.82€ betragen und der SSE hier 305680.200 beträgt.
Grundsätzlich sagt uns dies, dass die wichtigste Variable, die anfangs den größten Rückgang der SSE aufweist, der Wochentag ist, wobei die durchschnittlichen Umsätze am Sonntag in der Warengruppe Kuchen um > 64% höher sind als an den anderen Wochentagen.
Wir visualisieren unser Modell mit erneut rpart.plot.
Man kann feststellen, dass dieser Baum 9 interne Knoten enthält, was zu 10 Endknoten führt.
Die gestrichelte Linie, die etwa durch den Punkt | T | = 8 verläuft, deutet abermals darauf hin, dass auch ein kleiner Baum gewählt werden kann. Wir könnten nach der 1-SE-Regel auch einen Baum mit 8 Endknoten verwenden und vernünftigerweise erwarten, dass innerhalb einer kleinen Fehlergrenze ähnliche Ergebnisse erzielt werden.
## CP nsplit rel error xerror xstd
## 1 0.26999013 0 1.0000000 1.0015938 0.08760564
## 2 0.06560065 1 0.7300099 0.7337160 0.06485762
## 3 0.06121428 2 0.6644092 0.7214330 0.06215531
## 4 0.02833587 3 0.6031949 0.6313104 0.04499674
## 5 0.02769333 5 0.5465232 0.6240927 0.04481083
## 6 0.02219135 6 0.5188299 0.6042765 0.04283639
## 7 0.01765547 7 0.4966385 0.5791948 0.04019783
## 8 0.01169102 8 0.4789830 0.5378376 0.03538477
## 9 0.01000000 9 0.4672920 0.5287996 0.03413648
Tuning - Warengruppe 4
Neben dem Kostenkomplexität (α)-Parameter ist es auch üblich folgende Parameter anzupassen:
minsplit: Die Mindestanzahl von Datenpunkten, die erforderlich sind, um eine Teilung zu versuchen, bevor ein Endknoten erstellt werden muss. Der Standardwert ist 20. Wenn man diesen Wert verkleinert, können Endknoten, die möglicherweise nur eine Handvoll Beobachtungen enthalten, erstellt werden um den vorhergesagten Wert zu prognostizieren.maxdepth: Die maximale Anzahl interner Knoten zwischen dem Wurzelknoten und den Endknoten. Der Standardwert ist 30, was ziemlich liberal ist und das Bauen ziemlich großer Bäume ermöglicht.
rpart verwendet ein spezielles Steuer- bzw. Kontrollargument, bei dem eine Liste von Hyperparameterwerten bereitgestellt wird. Wenn wir beispielsweise ein Modell mit minsplit = 20 und maxdepth = 12 bewerten möchten, können wir Folgendes ausführen:
dt2_WG4 <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG4,
method = "anova",
control = list(minsplit = 20, maxdepth = 12, xval = 10)
)
dt2_WG4$cptable## CP nsplit rel error xerror xstd
## 1 0.26999013 0 1.0000000 1.0024817 0.08748283
## 2 0.06560065 1 0.7300099 0.7339380 0.06489467
## 3 0.06121428 2 0.6644092 0.7185371 0.06342554
## 4 0.02833587 3 0.6031949 0.6264666 0.04523980
## 5 0.02769333 5 0.5465232 0.6067093 0.04429601
## 6 0.02219135 6 0.5188299 0.6018071 0.04333675
## 7 0.01765547 7 0.4966385 0.5700485 0.04031648
## 8 0.01169102 8 0.4789830 0.5259447 0.03466679
## 9 0.01000000 9 0.4672920 0.5305860 0.03503777
Obwohl dieser Ansatz nützlich ist, müssen mehrere Modelle manuell bewertet werden. Besser ist es insofern eine Rastersuche durchzuführen, um automatisch nach einer Reihe unterschiedlich abgestimmter Modelle zu suchen, um die optimale Hyperparametereinstellung zu ermitteln.
Um eine Rastersuche durchzuführen, erstellen wir zuerst unser Hyperparameter-Raster. In diesem Beispiel suchen wir einen Bereich von minsplit von 5 bis 150 und variiere die maximale Tiefe von 8 bis 15 (da unser ursprüngliches Modell eine optimale Tiefe von 11 gefunden hat). Das Ergebnis sind 1168 verschiedene Kombinationen, für die 1168 verschiedene Modelle erforderlich sind.
## minsplit maxdepth
## 1 5 8
## 2 6 8
## 3 7 8
## 4 8 8
## 5 9 8
## 6 10 8
## [1] 1168
Um die Modellierung zu automatisieren, richten wir einfach eine for-Schleife ein und durchlaufen jede Kombination aus minsplit und maxdepth. Wir speichern jedes Modell in einem eigenen Listenelement.
models <- list()
for (i in 1:nrow(hyper_grid)) {
# minsplit, maxdepth values in Zeile i
minsplit <- hyper_grid$minsplit[i]
maxdepth <- hyper_grid$maxdepth[i]
# Trainiere ein Modell und speichere es in der Liste
models[[i]] <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG4,
method = "anova",
control = list(minsplit = minsplit, maxdepth = maxdepth)
)
}Wir erstellen erneut eine Funktion, um den minimalen Fehler zu extrahieren, der mit dem α-Wert der optimalen Kostenkomplexität für jedes Modell verbunden ist.
# Funktion um den optimalen cp zu erreichen
get_cp <- function(x) {
min <- which.min(x$cptable[, "xerror"])
cp <- x$cptable[min, "CP"]
}
# Funktion um den minimalen Fehler zu erhalten
get_min_error <- function(x) {
min <- which.min(x$cptable[, "xerror"])
xerror <- x$cptable[min, "xerror"]
}
hyper_grid %>%
mutate(
cp = purrr::map_dbl(models, get_cp),
error = purrr::map_dbl(models, get_min_error)
) %>%
arrange(error) %>%
top_n(-5, wt = error)## minsplit maxdepth cp error
## 1 5 10 0.01 0.5012899
## 2 9 12 0.01 0.5021723
## 3 7 11 0.01 0.5030950
## 4 10 9 0.01 0.5040660
## 5 13 11 0.01 0.5043320
Es ist erkennbar, dass das optimale Modell eine leichte Verbesserung gegenüber unserem früheren Modell darstellt (xerror von 0.5018793 gegenüber 0.5157798).
Wenn die Ergebnisse zufriedenstellend sind, kann dieses endgültige optimale Modell angewendet werden und auf dem Testsatz vorhersagen.
optimal_tree_WG4 <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG4,
method = "anova",
control = list(minsplit = 13, maxdepth = 12, cp = 0.01)
)
pred <- predict(optimal_tree_WG4, newdata = df_dt_test_WG4)
RMSE(pred = pred, obs = df_dt_test_WG4$Umsatz)## [1] 24.31214
Der endgültige RMSE beträgt 24.31, was darauf hindeutet, dass unsere prognostizierten Umsätze im Durchschnitt etwa 24.31 € vom tatsächlichen Umsatz abweichen.
# Hinzufügen der Ergebnisse
df_dt_test_WG4 <- df_dt_test_WG4 %>%
mutate(predicted = pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_dt_test_WG4 <- df_dt_test_WG4 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_dt_test_WG4 <- df_dt_test_WG4 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_dt_test_WG4 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "optimaltree_WG4")
# füge die Kennzahlen nun an die Vergleichstabelle
dt_vgl_kennz <- rbind(dt_vgl_kennz, temp)
dt_vgl_kennz## # A tibble: 4 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 27.7 -5.68 20.9 20.9 1582. 39.8 30.1
## 2 346 130413. 377. 50.5 4.25 14.0 13.4 4292. 65.5 17.4
## 3 346 59316. 171. 36.1 -7.43 19.7 21.0 2582. 50.8 29.6
## 4 345 28354. 82.2 17.3 6.35 22.2 21.1 591. 24.3 29.6
## # ... with 1 more variable: Modell <chr>
Grundlegende Implementierung - Warengruppe 5
Abschließend wird nun noch ein Entscheidungsbaum für Warengruppe 5 erstellt.
# Warengruppe 5
dt1_WG5 <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG5,
method = "anova"
)
dt1_WG5## n= 1061
##
## node), split, n, deviance, yval
## * denotes terminal node
##
## 1) root 1061 9542791.00 265.6068
## 2) Feiertag< 0.5 1040 3458236.00 260.8128
## 4) Wochentag_c=Dienstag,Donnerstag,Freitag,Mittwoch,Montag 743 1693783.00 246.5031
## 8) Monat_c=April,Dezember,Januar,März,November 307 586213.20 221.0646
## 16) Herbst>=0.5 102 75452.36 190.8896 *
## 17) Herbst< 0.5 205 371676.30 236.0785 *
## 9) Monat_c=August,Februar,Juli,Juni,Mai,Oktober,September 436 769020.00 264.4150
## 18) SommerferienSH< 0.5 347 492842.40 255.5571 *
## 19) SommerferienSH>=0.5 89 142797.40 298.9510 *
## 5) Wochentag_c=Samstag,Sonntag 297 1231696.00 296.6112
## 10) Monat_c=April,Dezember,Januar,Juli,Juni,Mai,März,November,Oktober 223 757522.10 282.9643 *
## 11) Monat_c=August,Februar,September 74 307486.50 337.7366 *
## 3) Feiertag>=0.5 21 4876955.00 503.0233
## 6) Bewoelkung< 6.5 13 10042.37 297.9608 *
## 7) Bewoelkung>=6.5 8 3431934.00 836.2500 *
Der dt1_WG5-Output beginnt mit 1061 Beobachtungen am Wurzelknoten (ganz am Anfang) und die erste Variable, die zur Teilung verwendet wird (also die erste Variable, die eine Reduzierung der SSE optimiert), ist bei dieser Warengruppe der Feiertag. Wir sehen, dass am ersten Knoten alle Beobachtungen mit Feiertag< 0.5 zum zweiten Zweig gehen. Die Gesamtzahl der Beobachtungen, die diesem Zweig folgen (743), der durchschnittliche Umsatz (246.50) und der SSE (1693783.00) sind aufgeführt.
Wenn man nach dem 3. Zweig sucht, sieht man, dass 21 Beobachtungen mit Feiertag> 0.5 diesem Zweig folgen und ihre durchschnittlichen Umsätze 503.02€ betragen und der SSE hier 4876955.00 beträgt.
Grundsätzlich sagt uns dies, dass die wichtigste Variable, die anfangs den größten Rückgang der SSE aufweist, der Feiertag ist, wobei die durchschnittlichen Umsätze am Feiertag in der Warengruppe Konditorei um > 100% höher sind als an den Nicht-Feiertagen.
Wir visualisieren unser Modell mit erneut rpart.plot.
Man kann feststellen, dass dieser Baum 7 interne Knoten enthält, was zu 8 Endknoten führt.
Die gestrichelte Linie verläuft hier durch keinen Punkt. Ein Baum mit 8 Knoten ist somit scheinbar der kleinstmögliche.
## CP nsplit rel error xerror xstd
## 1 0.13845945 0 1.0000000 1.0026906 0.3747587
## 2 0.05582824 2 0.7230811 1.0454630 0.3620755
## 3 0.03547701 3 0.6672529 0.9627282 0.3381496
## 4 0.01746737 4 0.6317759 0.9377907 0.3453332
## 5 0.01457483 5 0.6143085 0.9340402 0.3453169
## 6 0.01397706 6 0.5997337 0.9267918 0.3453275
## 7 0.01000000 7 0.5857566 0.8997721 0.3412891
Tuning - Warengruppe 5
Neben dem Kostenkomplexität (α)-Parameter ist es auch üblich folgende Parameter anzupassen:
minsplit: Die Mindestanzahl von Datenpunkten, die erforderlich sind, um eine Teilung zu versuchen, bevor ein Endknoten erstellt werden muss. Der Standardwert ist 20. Wenn man diesen Wert verkleinert, können Endknoten, die möglicherweise nur eine Handvoll Beobachtungen enthalten, erstellt werden um den vorhergesagten Wert zu prognostizieren.maxdepth: Die maximale Anzahl interner Knoten zwischen dem Wurzelknoten und den Endknoten. Der Standardwert ist 30, was ziemlich liberal ist und das Bauen ziemlich großer Bäume ermöglicht.
rpart verwendet ein spezielles Steuer- bzw. Kontrollargument, bei dem eine Liste von Hyperparameterwerten bereitgestellt wird. Wenn wir beispielsweise ein Modell mit minsplit = 20 und maxdepth = 10 bewerten möchten, können wir Folgendes ausführen:
dt2_WG5 <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG5,
method = "anova",
control = list(minsplit = 20, maxdepth = 10, xval = 10)
)
dt2_WG5$cptable## CP nsplit rel error xerror xstd
## 1 0.13845945 0 1.0000000 1.0012955 0.3743632
## 2 0.05582824 2 0.7230811 1.1093221 0.3652235
## 3 0.03547701 3 0.6672529 1.0109341 0.3390196
## 4 0.01746737 4 0.6317759 1.0023155 0.3527340
## 5 0.01457483 5 0.6143085 0.9852475 0.3527515
## 6 0.01397706 6 0.5997337 0.9760148 0.3527580
## 7 0.01000000 7 0.5857566 0.9709971 0.3527705
Obwohl dieser Ansatz nützlich ist, müssen mehrere Modelle manuell bewertet werden. Besser ist es insofern eine Rastersuche durchzuführen, um automatisch nach einer Reihe unterschiedlich abgestimmter Modelle zu suchen, um die optimale Hyperparametereinstellung zu ermitteln.
Um eine Rastersuche durchzuführen, erstellen wir zuerst unser Hyperparameter-Raster. In diesem Beispiel suchen wir einen Bereich von minsplit von 5 bis 150 und variiere die maximale Tiefe von 8 bis 15 (da unser ursprüngliches Modell eine optimale Tiefe von 11 gefunden hat). Das Ergebnis sind 1168 verschiedene Kombinationen, für die 208 verschiedene Modelle erforderlich sind.
## minsplit maxdepth
## 1 5 8
## 2 6 8
## 3 7 8
## 4 8 8
## 5 9 8
## 6 10 8
## [1] 208
Um die Modellierung zu automatisieren, richten wir einfach eine for-Schleife ein und durchlaufen jede Kombination aus minsplit und maxdepth. Wir speichern jedes Modell in einem eigenen Listenelement.
models <- list()
for (i in 1:nrow(hyper_grid)) {
# minsplit, maxdepth values in Zeile i
minsplit <- hyper_grid$minsplit[i]
maxdepth <- hyper_grid$maxdepth[i]
# Trainiere ein Modell und speichere es in der Liste
models[[i]] <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG5,
method = "anova",
control = list(minsplit = minsplit, maxdepth = maxdepth)
)
}Wir erstellen erneut eine Funktion, um den minimalen Fehler zu extrahieren, der mit dem α-Wert der optimalen Kostenkomplexität für jedes Modell verbunden ist.
# Funktion um den optimalen cp zu erreichen
get_cp <- function(x) {
min <- which.min(x$cptable[, "xerror"])
cp <- x$cptable[min, "CP"]
}
# Funktion um den minimalen Fehler zu erhalten
get_min_error <- function(x) {
min <- which.min(x$cptable[, "xerror"])
xerror <- x$cptable[min, "xerror"]
}
hyper_grid %>%
mutate(
cp = purrr::map_dbl(models, get_cp),
error = purrr::map_dbl(models, get_min_error)
) %>%
arrange(error) %>%
top_n(-5, wt = error)## minsplit maxdepth cp error
## 1 5 11 0.01 0.6969198
## 2 6 8 0.01 0.7167273
## 3 7 8 0.01 0.7606331
## 4 9 9 0.01 0.7808490
## 5 30 10 0.01 0.7833203
Es ist erkennbar, dass das optimale Modell eine deutliche Verbesserung gegenüber unserem früheren Modell darstellt (xerror von 0.6213613 gegenüber 0.7828373).
Wenn die Ergebnisse zufriedenstellend sind, kann dieses endgültige optimale Modell angewendet werden und auf dem Testsatz vorhersagen.
optimal_tree_WG5 <- rpart(
formula = Umsatz ~ .,
data = df_dt_train_WG5,
method = "anova",
control = list(minsplit = 13, maxdepth = 10, cp = 0.01)
)
pred <- predict(optimal_tree_WG5, newdata = df_dt_test_WG5)
RMSE(pred = pred, obs = df_dt_test_WG5$Umsatz)## [1] 68.6513
Der endgültige RMSE beträgt 68.65, was darauf hindeutet, dass unsere prognostizierten Umsätze im Durchschnitt etwa 68.65 € vom tatsächlichen Umsatz abweichen.
# Hinzufügen der Ergebnisse
df_dt_test_WG5 <- df_dt_test_WG5 %>%
mutate(predicted = pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_dt_test_WG5 <- df_dt_test_WG5 %>%
mutate(Prognose_zuhoch = (predicted >= Umsatz)) %>%
mutate(Abweichung = predicted - Umsatz) %>%
mutate(Abweichung_abs = abs(predicted - Umsatz)) %>%
mutate(Abweichung_rel = (predicted - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_dt_test_WG5 <- df_dt_test_WG5 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_dt_test_WG5 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz), 2), Umsatz_mittel = round(sum(Umsatz)/n(), 2), MAE = round(mean(Abweichung_abs), 2), MPE = round(mean(Abweichung_rel)*100, 2), MAPE = round(mean(Abweichung_rel_abs)*100, 2), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100, 2), MSE = round(mean(Abweichung_quad), 2), RMSE = round(sqrt(mean(Abweichung_quad)), 2), rRMSE = round(RMSE/Umsatz_mittel*100, 2))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "optimaltree_WG5")
# füge die Kennzahlen nun an die Vergleichstabelle
dt_vgl_kennz <- rbind(dt_vgl_kennz, temp)
dt_vgl_kennz## # A tibble: 5 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738. 132. 27.7 -5.68 20.9 20.9 1582. 39.8 30.1
## 2 346 130413. 377. 50.5 4.25 14.0 13.4 4292. 65.5 17.4
## 3 346 59316. 171. 36.1 -7.43 19.7 21.0 2582. 50.8 29.6
## 4 345 28354. 82.2 17.3 6.35 22.2 21.1 591. 24.3 29.6
## 5 346 93912. 271. 41.1 0.37 14.6 15.2 4713 68.6 25.3
## # ... with 1 more variable: Modell <chr>
7.4 Fazit Decision Trees
Die Decision Trees liefern vergleichsweise gute Schätzwerte für die Warengruppen 4 (= Konditorei) und 5 (= Kuchen). Für Warengruppe 4 performt der Entscheidungsbaum insgesamt (deutlich) besser als das lineare Modell, aber immer noch schlechter als das naive. Das naive Modell liefert dabei insbesondere bessere Werte für den MPE, den WAPE sowie RMSE und rRMSE. Was Warengruppe 5 anbelangt, bleibt der Entscheidungsbaum knapp hinter dem linearen Modell zurück, was vor allem auf deutlich höhere Werte bei den Kennzahlen MSE, RMSE sowie rRMSE zurückzuführen ist.
Anders sieht es bei den verbleibenden Warengruppen 1, 2, und 3 aus. Zwar liefert der Entscheidungsbaum für Warengruppe 1 bessere Werte als das naive Modell, performt aber andereseits deutlich schlechter als das lineare Modell. In den anderen Warengruppen 2 und 3 landen die Entscheidungsbäume hinter den anderen getesteten Modellen. Am schlechtesten scheinen Entscheidungsbäume für die Prognose der Umsätze in der Warengruppe 3 zu sein. Für diese Warengruppe ergeben sich deutlich schlechtere Werte bei nahezu allen Gütekennzahlen (Ausnahme: der MPE, der beim lm -8 und beim DT -7 beträgt).
Allgemein betrachtet noch folende Ergänzungen:
Stärken und Schwächen
Regressionsbäume bieten mehrere Vorteile:
- Sie sind sehr gut / einfach interpretierbar.
- Vorhersagen zu treffen geht vglw. schnell (keine komplizierten Berechnungen, nur nach Konstanten im Baum suchen).
- Es ist leicht zu verstehen, welche Variablen für die Vorhersage wichtig sind. Die internen Knoten (Splits) sind diejenigen Variablen, die die SSE am stärksten reduziert haben.
- Wenn einige Daten fehlen, können wir möglicherweise nicht den ganzen Weg den Baum hinunter zu einem Blatt gehen, aber wir können trotzdem eine Vorhersage treffen, indem wir alle Blätter in dem Teilbaum mitteln, den wir erreichen.
- Das Modell bietet eine nichtlineare „gezackte“ Antwort, sodass es funktionieren kann, wenn die wahre Regressionsfläche nicht “glatt” ist. Wenn es jedoch glatt ist, kann die stückweise konstante Oberfläche es beliebig genau annähern (mit genügend Blättern).
- Es gibt schnelle und zuverlässige Algorithmen, um diese Bäume zu lernen.
Es gibt aber auch einige wesentliche Schwächen:
- Einzelne Regressionsbäume weisen eine hohe Varianz auf, was zu instabilen Vorhersagen führt (eine alternative Teilstichprobe von Trainingsdaten kann die Endknoten erheblich verändern).
- Aufgrund der hohen Varianz weisen einzelne Regressionsbäume eine schlechte Vorhersagegenauigkeit auf.
8 Anwendung von ML Verfahren: Support Vector Machines (SVM)
8.1 Vorhaben und Theorie
Wir testen nun ein anerkanntes Verfahren aus dem Bereich Machine Learning (ML), nämlich Support Vector Machines (SVM). Dieses Verfahren wird häufig für die Klassifizierung verwendet, kann jedoch auch zur Lösung von Regressions-Problemen verwendet werden. Genau das wollen wir tun.
Lineare SVM zur Klassifizierung
In der einfachsten Form hat man ein Trainingsset \(D=\{(\vec{x}^{(1)},y^{(1)}),...,(\vec{x}^{(p)},y^{(p)})\}\) bestehend aus \(p\) Eingabevektoren \(\vec{x}\) mit zugehörigem Label \(y\), beispielsweise \(+1\) und \(-1\).
Im Bild sehen wir ein Beispiel in zwei Dimensionen: Die roten Quadrate haben Label \(+1\), die grünen Kreise \(-1\). Man sucht dann die Trennlinie (durchgezogene Linie), die den Sicherheitsabstand (“Marge” oder engl. “margin”) maximiert. Dir Grenzen der Sicherheitszone sind durch die gestrichelten Linien gezeigt. Die Datenpunkte, die direkt auf den getrennten Linien liegen haben als Abstand gerade die doppelte Marge und werden als Support-Vektoren bezeichnet. Für die Lösung des Problems sind nämlich gerade die Support-Vektoren entscheidend.
Die Trennlinie (in höheren Dimensionen Hyperebene) lässt sich beschreiben als \(H=\{\vec{x}|\vec{w}^T\cdot\vec{x}+b=0\}\). Dabei bezeichnet \(\vec{w}\) den Normal-Vektor der Hyperebene. Und als Lösung erhalten wir eine Klassifizierungsfunktion \(f(\vec{x})=sgn(\vec{w}^T\cdot\vec{x}+b)\). Dieser Klassifizierer ist unsere Support Vector Machine.
Das Problem ist, dass die Hyperebene durch \(\vec{w}\) nicht eindeutig bestimmt ist. Wir legen daher durch Normierung die sogenannte kanonische Hyperebene fest. Konkret erreichen wir das durch die Nebenbedingungen \((*)\): \(\vec{w}^T\cdot\vec{x}+b \ge +1\) für Support-Vektoren mit Label \(+1\) und \(\vec{w}^T\cdot\vec{x}+b \le -1\) für Support-Vektoren mit Label \(-1\). Damit ergibt sich der Sicherheitsabstand zwischen den beiden gestrichelten Linien zu \(\frac{2}{||\vec{w}||}\).
Jetzt haben wir ein Optimierungsproblem und müssen \(||\vec{w}||\) minimieren, um den Sicherheitsabstand zu maximieren, unter den Nebenbedingungen \((*)\). Bei der Lösung kommen Lagrange-Multiplikatoren \(\alpha_\mu\ge0\) ins Spiel und liefern als Lösung die optimalen Werte \(\vec{w}^*\) und \(b^*\) mit \(\vec{w}^*=\sum_{\mu=1}^{p}\alpha_\mu y^{(\mu)}\vec{x}^{(\mu)}\). Die Details sparen wir an dieser Stelle aus.
Damit erhalten wir die Klassifizierungsfunktion \(f(\vec{x})=sgn(\vec{w}^{*T}\cdot\vec{x}+b^*)=sgn(\sum_{\mu=1}^{p}\alpha_\mu y^{(\mu)}\vec{x}^{(\mu)T}\cdot\vec{x}+b^*)\).
Klassifizierung von linear nicht trennbaren Datensätzen
SVM kann auch angewendet werden, wenn keine scharfe Trennung zwischen den Klassen möglich ist. In solchen Fällen verwendet man die sogenannte Soft-Margin-Klassifizierung. Ziel dabei ist eine Trennlinie zu finden, die die Anzahl der Punkte innerhalb des Sicherheitsabstandes minimiert bzw. die Anzahl der falsch klassifizierten Datenpunkte minimiert. Durch diese Nebenbedingung kommt ein weiterer Parameter \(C\) (“cost”) ins Spiel.
Nicht-lineare SVM zur Klassifizierung
Bislang haben skizziert, wie man SVM auf linear trennbare Datensätze anwendet - abgesehen von einigen Überlappungen der Daten unterschiedlicher Klassen. Aber SVM kann noch mehr:
Im oberen Teil der Abbildung sehen wir Daten zweier Klassen (rote und blaue Kreise), die in einer Dimension linear nicht trennbar sind. Transformiert man die Daten jedoch in eine höhere Dimension (hier 2D) durch eine Funktion \(\vec{x}\rightarrow\Phi(\vec{x})\), sieht man, dass die Klassen nun linear trennbar sind. Man spricht von einer Transformation in den höher-dimensionalen “Feature-Raum” und führt dann SVM eben in diesem Feature-Raum durch.
Dabei nutzt man aus, dass die transformierten Eingabevektoren \(\Phi(\vec{x})\) nur in Form von Skalarprodukten auftauchen und definiert eine sogenannte Kernel-Funktion \(k(.,.)\), um den Zusammenhang zwischen Eingabevektoren und transformierten Eingabevektoren im Feature-Raum zu vereinfachen: \(k(\vec{x},\vec{y})=\Phi(\vec{x})^T\cdot\Phi(\vec{y})\).
Wir verwenden später als Kernel \(k(\vec{x},\vec{y})=exp(-\gamma(\vec{x}-\vec{y})^2)\), also eine Gauss-Funktion, die man auch als “Radial-Basis-Funktion” (rbf) bezeichnet. Unsere Klassifizierungsfunktion wird dann zu:
\(f(\vec{x})=sgn(\sum_{\mu=1}^{p}\alpha_\mu y^{(\mu)}\Phi(\vec{x}^{(\mu)})^T\cdot\Phi(\vec{x})+b^*)=sgn(\sum_{\mu=1}^{p}\alpha_\mu y^{(\mu)}k(\vec{x}^{(\mu)},\vec{x})+b^*)\).
SVM zur Regression
Verzichten wir in der Klassifizierungsfunktion \(f(.)\) auf \(sgn(.)\) und verwenden stattdessen nur das Argument, dann können wir SVM auch auf Regressions-Probleme anwenden. Wir wollen dabei eine Funktion \(f(\vec{x})\) finden mit möglichst geringem Fehler \(|f(\vec{x})-y|\) bei Anwendung auf den Testdaten. Dabei besteht die Gefahr von Overfitting, nämlich dass wir den Schätzer zu gut an die Besonderheiten in den verwendeten Trainingsdaten anpassen und gleichzeitig die Prognosequalität bei Anwendung auf neue unbekannte Eingabewerte sinkt (schlechte Veralgemeinerung). Um diesen Interessenskonflikt zu lösen, führt man in der später durchgeführten \(\epsilon\)-Regression einen Toleranzbereich \(\epsilon\) ein, innerhalb dessen wir Abweichungen nicht bestrafen. Mathematisch ausgedrückt gilt für die Loss-Funktion \(L_\epsilon=0\) für \(|f(\vec{x})-y|\le\epsilon\).
Als freie Parameter haben wir also \(C\) (“cost”) und \(\epsilon\), die es zu optimieren gilt. Dafür verwenden wir später eine Funktion zum Tuning der Hyperparameter. Daneben haben wir in unserem rbf-Kernel noch den Parameter \(\gamma\), der üblicherweise als Kehrwert der Anzahl der Eingabeparameter festgelegt wird.
Die SVM-Funktionalitäten sind im R-Paket “e1071” implementiert.
8.2 Datenaufbereitung
Wir arbeiten mit dem vollständigen Datensatz df_voll. Dieser enthält im Zeitraum 01.07.2013 bis 31.07.2019 eine Zeile für jedes Datum und jede Warengruppe. In den Rohdaten fehlende Umsätze sind auf Basis der Vorwochenwerte ergänzt worden. Die Zeilen mit ergänzten Umsätzen sind selektierbar über die Variable Umsatz_NA (= TRUE).
Für unser Vorhaben beschränken wir uns auf die in den Rohdaten vorhandenen Umsätze (Umsatz_NA = FALSE). Und wir schränken die Trainingsdaten später auf den Zeitraum 2015 bis 2017 ein, weil wir oben gesehen hatten, dass die Umsätze in 2014 systematisch höher liegen als in den folgenden Jahren. Die Umsätze des Jahres 2018 dienen uns dann als Testdaten.
Wir erstellen für diesen Abschnitt einen Analysedatensatz df_SVM auf Basis von df_voll. Redundante Spalten nehmen wir raus (Wochentag, Monat, Jahreszeit) und entfernen die nicht benötigten Umsatz-Spalten (Umsatz_NA sowie die Umsatz_lag Variablen).
df_SVM <- df_voll
# verwende nur originäre Umsatzdaten und grenze den Zeitraum auf 2015 bis 2018 ein
df_SVM <- df_SVM %>%
filter(Umsatz_NA == FALSE) %>%
filter(Jahr >= 2015 & Jahr <= 2018)
# behalte nur die Spalten, die wir für unsere SVM verwenden wollen
df_SVM <- df_SVM %>%
dplyr::select(-Wochentag, -Monat, -Jahreszeit, -Umsatz_NA, -Umsatz_lag_1W, -Umsatz_lag_2W, -Umsatz_lag_3W, -Umsatz_lag_4W, -Umsatz_lag)Wir eleminieren nun fehlende Werte, dummyfizieren Wochentag_c und Monat_c (wobei wir im Gegensatz zur linearen Regression alle Wochentage und alle Monate behalten) und skalieren die Variablen Temperatur, Bewoelkung und Windgeschwindigkeit auf Werte im Bereich zwischen 0 und 1. Danach werden die alten Variablen Wochentag_c und Monat_c entfernt.
# eliminiere fehlende Werte
df_SVM <- na.omit(df_SVM)
# dummyfiziere Wochentag_c und Monat_c
df_SVM <- df_SVM %>%
mutate(Montag=as.integer(df_SVM$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_SVM$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_SVM$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_SVM$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_SVM$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_SVM$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_SVM$Wochentag_c=="Sonntag")) %>%
dplyr::select(-Wochentag_c)
df_SVM <- df_SVM %>%
mutate(Januar=as.integer(df_SVM$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_SVM$Monat_c=="Februar")) %>%
mutate(März=as.integer(df_SVM$Monat_c=="März")) %>%
mutate(April=as.integer(df_SVM$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_SVM$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_SVM$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_SVM$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_SVM$Monat_c=="August")) %>%
mutate(September=as.integer(df_SVM$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_SVM$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_SVM$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_SVM$Monat_c=="Dezember")) %>%
dplyr::select(-Monat_c)
# skaliere die Variablen Temperatur, Bewoelkung und Windgeschwindigkeit auf [0,1].
# ermittle vorher die Spannweite der Variablenausprägungen
range(df_SVM$Umsatz) # 23..1870## [1] 23.11 1869.94
## [1] -6.1 32.7
## [1] 0 8
## [1] 3 35
df_SVM <- df_SVM %>%
# mutate(Umsatz = Umsatz / 2000) %>%
mutate(Temperatur = (Temperatur + 10) / 50) %>%
mutate(Bewoelkung = Bewoelkung / 10) %>%
mutate(Windgeschwindigkeit = Windgeschwindigkeit / 50)Für die Trainingsdaten verwenden wir den Zeitraum 2015 bis 2017 und für die Testdaten das Jahr 2018. Die Modellierung erfolgt je Warengruppe, daher teilen wir den Datensatz df_SVM auf.
df_SVM_train <- df_SVM %>% filter(Jahr < 2018)
df_SVM_test <- df_SVM %>% filter(Jahr == 2018)
df_SVM_train_WG1 <- df_SVM_train %>% filter(Warengruppe==1)
df_SVM_train_WG2 <- df_SVM_train %>% filter(Warengruppe==2)
df_SVM_train_WG3 <- df_SVM_train %>% filter(Warengruppe==3)
df_SVM_train_WG4 <- df_SVM_train %>% filter(Warengruppe==4)
df_SVM_train_WG5 <- df_SVM_train %>% filter(Warengruppe==5)
df_SVM_test_WG1 <- df_SVM_test %>% filter(Warengruppe==1)
df_SVM_test_WG2 <- df_SVM_test %>% filter(Warengruppe==2)
df_SVM_test_WG3 <- df_SVM_test %>% filter(Warengruppe==3)
df_SVM_test_WG4 <- df_SVM_test %>% filter(Warengruppe==4)
df_SVM_test_WG5 <- df_SVM_test %>% filter(Warengruppe==5)Wir müssen dann noch die Trainings- und Testdaten aufteilen: Für die Erstellung der Inputdaten eliminieren wir die ersten vier Spalten, also Datum, Umsatz, Warengruppe und Jahr. Und die Targetvariable ist stets der Umsatz. Zunächst arbeiten wir mit ALLEN Inputvariablen.
# Warengruppe 1
df_SVM_train_WG1_input <- df_SVM_train_WG1 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_train_WG2_input <- df_SVM_train_WG2 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_train_WG3_input <- df_SVM_train_WG3 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_train_WG4_input <- df_SVM_train_WG4 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_train_WG5_input <- df_SVM_train_WG5 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_train_WG1_target <- df_SVM_train_WG1$Umsatz
df_SVM_train_WG2_target <- df_SVM_train_WG2$Umsatz
df_SVM_train_WG3_target <- df_SVM_train_WG3$Umsatz
df_SVM_train_WG4_target <- df_SVM_train_WG4$Umsatz
df_SVM_train_WG5_target <- df_SVM_train_WG5$Umsatz
df_SVM_test_WG1_input <- df_SVM_test_WG1 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_test_WG2_input <- df_SVM_test_WG2 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_test_WG3_input <- df_SVM_test_WG3 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_test_WG4_input <- df_SVM_test_WG4 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_test_WG5_input <- df_SVM_test_WG5 %>% dplyr::select(-Datum, -Umsatz, -Warengruppe, -Jahr)
df_SVM_test_WG1_target <- df_SVM_test_WG1$Umsatz
df_SVM_test_WG2_target <- df_SVM_test_WG2$Umsatz
df_SVM_test_WG3_target <- df_SVM_test_WG3$Umsatz
df_SVM_test_WG4_target <- df_SVM_test_WG4$Umsatz
df_SVM_test_WG5_target <- df_SVM_test_WG5$Umsatz8.3 Modelparameter
Wir wollen im folgenden eine Regression mithilfe von SVM durchführen und verwenden dafür einen radial basis kernel. Die einzelnen Schritte führen wir zunächst für Warengruppe 1 im Detail durch und anschließend für die übrigen Warengruppen.
Warengruppe 1
# Modellierung auf Basis der Trainings-Inputs
model_SVM_WG1 <- svm(df_SVM_train_WG1_input, df_SVM_train_WG1_target)
summary(model_SVM_WG1)##
## Call:
## svm.default(x = df_SVM_train_WG1_input, y = df_SVM_train_WG1_target)
##
##
## Parameters:
## SVM-Type: eps-regression
## SVM-Kernel: radial
## cost: 1
## gamma: 0.02380952
## epsilon: 0.1
##
##
## Number of Support Vectors: 926
# Anwendung des Modells auf die Trainings-Inputs
SVM_train_WG1_pred <- predict(model_SVM_WG1, df_SVM_train_WG1_input)
# Anwendung des Modells auf die Test-Inputs
SVM_test_WG1_pred <- predict(model_SVM_WG1, df_SVM_test_WG1_input)Für einen schnellen Überblick zeigen wir die echten Umsätze (schwarze Punkte) zusammen mit den prognostizierten Umsätzen (blaue Kreuze) für die Trainingsdaten. Die echten Umsätze sind hier auf der Diagonalen dargestellt, die Schätzwerte schwanken darum:
plot(df_SVM_train_WG1_target, df_SVM_train_WG1_target, pch=16)
points(df_SVM_train_WG1_target, SVM_train_WG1_pred, col = "blue", pch=4)Zeige die echten Umsätze (schwarze Punkte) zusammen mit den prognostizierten Umsätzen (blaue Kreuze) für die Testdaten:
plot(df_SVM_test_WG1_target, df_SVM_test_WG1_target, pch=16)
points(df_SVM_test_WG1_target, SVM_test_WG1_pred, col = "blue", pch=4)Die Modellparameter sind vorbelegt mit epsilon=0.1 und cost=1 (C). Gamma erhält als Startwert den Kehrwert der Anzahl der Inputparameter. Wir wollen nun epsilon und C optimieren, um die Modellergebnisse zu verbessern. Dafür verwenden wir eine Rasteranalyse und variieren beide Parameter (grid search). Anschließend verwenden wir das gefundene Optimum:
# Die Rastersuche nach dem Optimum dauert einige Minuten, daher auskommentiert.
# model_SVM_WG1_tuned_grid <- tune(svm, df_SVM_train_WG1_input, df_SVM_train_WG1_target, ranges = list(epsilon = seq(0,1,0.1), cost = 2^(2:9)))
# Verwende das beste Modell (auskommentiert)
# model_SVM_WG1_tuned <- model_SVM_WG1_tuned_grid$best.model
# summary(model_SVM_WG1_tuned)
# Zur Zeitersparnis verwende nur die gefundenen optimalen Parameter: cost = 4, epsilon = 0.5
model_SVM_WG1_tuned <- svm(df_SVM_train_WG1_input, df_SVM_train_WG1_target, cost=4, epsilon=0.5)Jetzt wenden wir das optimierte Modell nochmal auf die Trainings- und Testinputs an:
# Anwendung des Modells auf die Trainings-Inputs
SVM_train_WG1_pred_tuned <- predict(model_SVM_WG1_tuned, df_SVM_train_WG1_input)
# Anwendung des Modells auf die Test-Inputs
SVM_test_WG1_pred_tuned <- predict(model_SVM_WG1_tuned, df_SVM_test_WG1_input)Zeige die echten Umsätze (schwarze Punkte) zusammen mit den einfach prognostizierten Umsätzen (blaue Kreuze) und zusätzlich die Umsatzschätzung auf Basis des optimierten Modells (rote Kreuze) für die Trainingsdaten:
plot(df_SVM_train_WG1_target, df_SVM_train_WG1_target, pch=16)
points(df_SVM_train_WG1_target, SVM_train_WG1_pred, col = "blue", pch=4)
points(df_SVM_train_WG1_target, SVM_train_WG1_pred_tuned, col = "red", pch=4)Zeige die echten Umsätze (schwarze Punkte) zusammen mit den einfach prognostizierten Umsätzen (blaue Kreuze) und zusätzlich die Umsatzschätzung auf Basis des optimierten Modells (rote Kreuze) für die Testsdaten:
plot(df_SVM_test_WG1_target, df_SVM_test_WG1_target, pch=16)
points(df_SVM_test_WG1_target, SVM_test_WG1_pred, col = "blue", pch=4)
points(df_SVM_test_WG1_target, SVM_test_WG1_pred_tuned, col = "red", pch=4)Die Optimierung des Modells hat offenbar Erfolg: Besonders für die hohen Umsätze in der rechten Hälfte liegt der optimierte Schätzer (rote Kreuze) dichter am tatsächlichen Umsatz.
übrige Warengruppen
Die Modellparameter sind vorbelegt mit epsilon=0.1 und Cost=1 (C). Gamma erhält als Startwert den Kehrwert der Anzahl der Inputparameter. Wir wollen nun epsilon und C optimieren. Dafür verwenden wir wieder eine Rasteranalyse und variieren beide Parameter (grid search). Anschließend verwenden wir das gefundene Optimum:
# Die Rastersuche nach dem Optimum dauert einige Minuten, daher auskommentiert.
# model_SVM_WG2_tuned_grid <- tune(svm, df_SVM_train_WG2_input, df_SVM_train_WG2_target, ranges = list(epsilon = seq(0,1,0.1), cost = 2^(2:9)))
# model_SVM_WG3_tuned_grid <- tune(svm, df_SVM_train_WG3_input, df_SVM_train_WG3_target, ranges = list(epsilon = seq(0,1,0.1), cost = 2^(2:9)))
# model_SVM_WG4_tuned_grid <- tune(svm, df_SVM_train_WG4_input, df_SVM_train_WG4_target, ranges = list(epsilon = seq(0,1,0.1), cost = 2^(2:9)))
# model_SVM_WG5_tuned_grid <- tune(svm, df_SVM_train_WG5_input, df_SVM_train_WG5_target, ranges = list(epsilon = seq(0,1,0.1), cost = 2^(2:9)))
# Verwende das beste Modell (auskommentiert)
# model_SVM_WG2_tuned <- model_SVM_WG2_tuned_grid$best.model
# model_SVM_WG3_tuned <- model_SVM_WG3_tuned_grid$best.model
# model_SVM_WG4_tuned <- model_SVM_WG4_tuned_grid$best.model
# model_SVM_WG5_tuned <- model_SVM_WG5_tuned_grid$best.model
# summary(model_SVM_WG2_tuned) # cost = 4, epsilon = 0.2
# summary(model_SVM_WG3_tuned) # cost = 4, epsilon = 0.4
# summary(model_SVM_WG4_tuned) # cost = 4, epsilon = 0.8
# summary(model_SVM_WG5_tuned) # cost = 16, epsilon = 0.2
# Zur Zeitersparnis verwende nur die gefundenen optimalen Parameter: cost = 4, epsilon = 0.5
model_SVM_WG2_tuned <- svm(df_SVM_train_WG2_input, df_SVM_train_WG2_target, cost=4, epsilon=0.2)
model_SVM_WG3_tuned <- svm(df_SVM_train_WG3_input, df_SVM_train_WG3_target, cost=4, epsilon=0.4)
model_SVM_WG4_tuned <- svm(df_SVM_train_WG4_input, df_SVM_train_WG4_target, cost=4, epsilon=0.8)
model_SVM_WG5_tuned <- svm(df_SVM_train_WG5_input, df_SVM_train_WG5_target, cost=16, epsilon=0.2)Jetzt wenden wir die optimierten Modelle auf die Trainings- und Testinputs an:
# Anwendung des Modells auf die Trainings-Inputs
SVM_train_WG2_pred_tuned <- predict(model_SVM_WG2_tuned, df_SVM_train_WG2_input)
SVM_train_WG3_pred_tuned <- predict(model_SVM_WG3_tuned, df_SVM_train_WG3_input)
SVM_train_WG4_pred_tuned <- predict(model_SVM_WG4_tuned, df_SVM_train_WG4_input)
SVM_train_WG5_pred_tuned <- predict(model_SVM_WG5_tuned, df_SVM_train_WG5_input)
# Anwendung des Modells auf die Test-Inputs
SVM_test_WG2_pred_tuned <- predict(model_SVM_WG2_tuned, df_SVM_test_WG2_input)
SVM_test_WG3_pred_tuned <- predict(model_SVM_WG3_tuned, df_SVM_test_WG3_input)
SVM_test_WG4_pred_tuned <- predict(model_SVM_WG4_tuned, df_SVM_test_WG4_input)
SVM_test_WG5_pred_tuned <- predict(model_SVM_WG5_tuned, df_SVM_test_WG5_input)Zeige die echten Umsätze (schwarze Punkte) zusammen mit der Umsatzschätzung auf Basis des optimierten Modells (rote Kreuze) für die Trainingsdaten:
plot(df_SVM_train_WG2_target, df_SVM_train_WG2_target, pch=16)
points(df_SVM_train_WG2_target, SVM_train_WG2_pred_tuned, col = "red", pch=4)plot(df_SVM_train_WG3_target, df_SVM_train_WG3_target, pch=16)
points(df_SVM_train_WG3_target, SVM_train_WG3_pred_tuned, col = "red", pch=4)plot(df_SVM_train_WG4_target, df_SVM_train_WG4_target, pch=16)
points(df_SVM_train_WG4_target, SVM_train_WG4_pred_tuned, col = "red", pch=4)plot(df_SVM_train_WG5_target, df_SVM_train_WG5_target, pch=16)
points(df_SVM_train_WG5_target, SVM_train_WG5_pred_tuned, col = "red", pch=4)Zeige die echten Umsätze (schwarze Punkte) zusammen mit der Umsatzschätzung auf Basis des optimierten Modells (rote Kreuze) für die Testsdaten:
plot(df_SVM_test_WG2_target, df_SVM_test_WG2_target, pch=16)
points(df_SVM_test_WG2_target, SVM_test_WG2_pred_tuned, col = "red", pch=4)plot(df_SVM_test_WG3_target, df_SVM_test_WG3_target, pch=16)
points(df_SVM_test_WG3_target, SVM_test_WG3_pred_tuned, col = "red", pch=4)plot(df_SVM_test_WG4_target, df_SVM_test_WG4_target, pch=16)
points(df_SVM_test_WG4_target, SVM_test_WG4_pred_tuned, col = "red", pch=4)plot(df_SVM_test_WG5_target, df_SVM_test_WG5_target, pch=16)
points(df_SVM_test_WG5_target, SVM_test_WG5_pred_tuned, col = "red", pch=4)Den Plot für Warengruppe 5 machen wir nochmal hübsch, damit wir ihn in die Folien-Präsentation einbetten können:
# füge die tatsächlichen und geschätzten Umsätze für WG5 zusammen
# temp_sample <- 1:346
# temp_df_SVM_WG5 <- cbind(temp_sample, df_SVM_test_WG5_target, SVM_test_WG5_pred_tuned)
# passe die Spaltenbezeichnungen an
# colnames(temp_df_SVM_WG5) <- c("Tag", "Umsatz", "Prognose")
# pivotisieren als Vorbereitung für anschließenden Plot
# temp_df_SVM_WG5 <- temp_df_SVM_WG5 %>% pivot_longer(cols=c("Umsatz", "Prognose"), names_to = "Umsatz_Prognose", values_to = "Umsatz")
# Plot
# temp_df_SVM_WG5 %>%
# ggplot(mapping=aes(x=Tag, y=Umsatz)) +
# geom_point(aes(color=Umsatz_Prognose)) +
# ggtitle("2018 WG5 - Vergleich tatsächlicher Umsatz mit SVM-Prognose") +
# xlab("Tag") +
# ylab("Umsatz")8.4 Modellergebnisse
Zunächst wandeln wir die Umsatzschätzer in einen dataframe um und benennen die Spalte entsprechend:
SVM_test_WG1_pred_tuned <- as.data.frame(SVM_test_WG1_pred_tuned)
SVM_test_WG2_pred_tuned <- as.data.frame(SVM_test_WG2_pred_tuned)
SVM_test_WG3_pred_tuned <- as.data.frame(SVM_test_WG3_pred_tuned)
SVM_test_WG4_pred_tuned <- as.data.frame(SVM_test_WG4_pred_tuned)
SVM_test_WG5_pred_tuned <- as.data.frame(SVM_test_WG5_pred_tuned)
colnames(SVM_test_WG1_pred_tuned) <- "Umsatz_WG1"
colnames(SVM_test_WG2_pred_tuned) <- "Umsatz_WG2"
colnames(SVM_test_WG3_pred_tuned) <- "Umsatz_WG3"
colnames(SVM_test_WG4_pred_tuned) <- "Umsatz_WG4"
colnames(SVM_test_WG5_pred_tuned) <- "Umsatz_WG5"Dann fügen wir die Umsatzschätzer an die Testdaten an und erstellen eine gemeinsame Übersichtstabelle für die Gütekennzahlen prog_SVM_vgl_kennz:
# WG1
df_SVM_test_WG1 <- cbind(df_SVM_test_WG1, SVM_test_WG1_pred_tuned)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_SVM_test_WG1 <- df_SVM_test_WG1 %>%
mutate(Prognose_zuhoch = (Umsatz_WG1 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_WG1 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_WG1 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_WG1 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_SVM_test_WG1 <- df_SVM_test_WG1 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_SVM_test_WG1 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "WG1")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_SVM_vgl_kennz <- temp
# WG2
df_SVM_test_WG2 <- cbind(df_SVM_test_WG2, SVM_test_WG2_pred_tuned)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_SVM_test_WG2 <- df_SVM_test_WG2 %>%
mutate(Prognose_zuhoch = (Umsatz_WG2 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_WG2 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_WG2 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_WG2 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_SVM_test_WG2 <- df_SVM_test_WG2 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_SVM_test_WG2 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "WG2")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_SVM_vgl_kennz <- rbind(prog_SVM_vgl_kennz, temp)
# WG3
df_SVM_test_WG3 <- cbind(df_SVM_test_WG3, SVM_test_WG3_pred_tuned)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_SVM_test_WG3 <- df_SVM_test_WG3 %>%
mutate(Prognose_zuhoch = (Umsatz_WG3 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_WG3 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_WG3 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_WG3 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_SVM_test_WG3 <- df_SVM_test_WG3 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_SVM_test_WG3 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "WG3")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_SVM_vgl_kennz <- rbind(prog_SVM_vgl_kennz, temp)
# WG4
df_SVM_test_WG4 <- cbind(df_SVM_test_WG4, SVM_test_WG4_pred_tuned)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_SVM_test_WG4 <- df_SVM_test_WG4 %>%
mutate(Prognose_zuhoch = (Umsatz_WG4 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_WG4 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_WG4 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_WG4 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_SVM_test_WG4 <- df_SVM_test_WG4 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_SVM_test_WG4 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "WG4")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_SVM_vgl_kennz <- rbind(prog_SVM_vgl_kennz, temp)
# WG5
df_SVM_test_WG5 <- cbind(df_SVM_test_WG5, SVM_test_WG5_pred_tuned)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_SVM_test_WG5 <- df_SVM_test_WG5 %>%
mutate(Prognose_zuhoch = (Umsatz_WG5 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_WG5 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_WG5 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_WG5 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_SVM_test_WG5 <- df_SVM_test_WG5 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_SVM_test_WG5 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "WG5")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_SVM_vgl_kennz <- rbind(prog_SVM_vgl_kennz, temp)
prog_SVM_vgl_kennz## # A tibble: 5 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738 132 25 -6 19 19 1193 35 27
## 2 346 130413 377 42 2 12 11 3015 55 15
## 3 346 59316 171 32 -7 18 18 1762 42 25
## 4 345 28354 82 19 14 25 23 584 24 29
## 5 346 93912 271 43 0 16 16 3176 56 21
## # ... with 1 more variable: Modell <chr>
Nun wollen wir und noch die Verteilung der relativen Abweichungen der Umsatzschätzung vom tatsächlichen Umsatz angucken und erstellen dafür eine weitere Vergleichstabelle prog_SVM_vgl_relAbw. Diese müssen wir dann noch pivotisieren (pivot_longer) als Vorbereitung auf den Boxplot:
# füge die relativen Abweichungen für WG1 an und benenne die Spalte um
prog_SVM_vgl_relAbw <- df_SVM_test_WG1 %>% dplyr::select(Datum, Abweichung_rel)
colnames(prog_SVM_vgl_relAbw)[2]="WG1"
# füge die relativen Abweichungen für WG2 an und benenne die Spalte um
prog_SVM_vgl_relAbw <- left_join(prog_SVM_vgl_relAbw, df_SVM_test_WG2 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_SVM_vgl_relAbw)[3]="WG2"
# füge die relativen Abweichungen für WG3 an und benenne die Spalte um
prog_SVM_vgl_relAbw <- left_join(prog_SVM_vgl_relAbw, df_SVM_test_WG3 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_SVM_vgl_relAbw)[4]="WG3"
# füge die relativen Abweichungen für WG4 an und benenne die Spalte um
prog_SVM_vgl_relAbw <- left_join(prog_SVM_vgl_relAbw, df_SVM_test_WG4 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_SVM_vgl_relAbw)[5]="WG4"
# füge die relativen Abweichungen für WG5 an und benenne die Spalte um
prog_SVM_vgl_relAbw <- left_join(prog_SVM_vgl_relAbw, df_SVM_test_WG5 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_SVM_vgl_relAbw)[6]="WG5"
# pivotisieren
prog_SVM_vgl_relAbw <- prog_SVM_vgl_relAbw %>%
pivot_longer(cols=-c("Datum"), names_to="Modell", values_to="Abweichung_rel")
# Boxplot
prog_SVM_vgl_relAbw %>%
ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
geom_boxplot() + coord_flip() +
ggtitle("2018 - Vergleich SVM Modell 1: Relative Abweichung") +
xlab("Modell_Warengruppe") +
ylab("rel. Abweichung (%)") +
ylim(-100, 200)## Warning: Removed 2 rows containing non-finite values (stat_boxplot).
8.5 Fazit SVM-Modell
Unser SVM-Modell liefert sehr gute Schätzwerte für die Warengruppen 2 (= Brötchen) und 5 (= Kuchen). Und zwar liegt die mittlere relative Abweichung fast bei Null und der WAPE ist vergleichbar zum besten naiven und linearen Modell.
Auf der anderen Seite fällt auf, dass mit unserem SVM-Modell die Umsätze der Warengruppe 4 (= Konditorei) nur mangelhaft geschätzt werden: Der WAPE liegt relativ hoch und vor allem die mittlere relative Abweichung ist mit 14% deutlich entfernt von Null. Die Umsätze werden also systematisch stark zu hoch geschätzt.
Wir untersuchen nun, ob wir mit Deep Learning Methoden noch bessere Ergebnisse erzielen können.
9 Anwendung von DL Verfahren: Multilayer Perceptron (MLP)
9.1 Vorhaben und Theorie
Wir wollen in diesem Abschnitt ein Verfahren aus dem Bereich Deep Learning (DL) testen. Genauer gesagt wollen wir ein künstliches neuronales Netz (kNN) in Form eines einfach Multilayer Perceptrons aufbauen. Ein Perpeptron bezeichnet dabei die Grundeinheit (unit) unseres Netzes und ist eine vereinfachte künstliche Nervenzelle.
Die Abbildung zeigt ein solches Perceptron mit zwei Eingabewerten \(x_1\) und \(x_2\), sowie Gewichten \(w_1\), \(w_2\) und einer Schwelle \(\theta\). Der Ausgabewert \(y\) ergibt sich durch Anwendung einer sogenannten Aktivierungsfunktion \(f(.)\) auf die Summe der gewichteten Eingabewerte abzüglich Schwellwert. Dabei wird häufig \(b=-\theta\) gesetzt: \(y=f(h)=f(\vec{x}\cdot\vec{w}+b)\), wobei mit \(h\) das postsynaptische Potential bezeichnet wird. Beispiele für Aktivierungsfunktionen sind die Heaviside-Stufenfunktion, einfache lineare Funktionen \(f(h)=h\), gerichtete lineare Funktionen (“relu” = rectified linear units) \(f(h)=max(h,0)\) oder sigmoide Funktionen \(f(h)=\frac{1}{1+e^{-h}}\).
Mehrere Perceptrons bilden eine Schicht eines neuronalen Netzes. Und ein Netz besteht in der Regel aus einer Eingabeschicht (input layer), einer Ausgabeschicht (output layer) und optional Zwischenschichten (hidden layers), wie im Bild skizziert:
Wir haben in dieser Arbeit nur sogenannte Feedforward-Netze benutzt, bei denen die Signalrichtung immer nur von einer zur nächsten Schicht zeigt. Im Grundzustand ist jede Einheit einer Schicht mit jeder Einheit der nächsten Schicht verbunden und die Verbindung erhält ein Gewicht \(w\).
Für eine Kombination von Eingabewerten lässt sich der Ausgabewert in einem Feedforward-Netz sehr einfach berechnen. In unserem Fall haben wir eine Reihe von Trainingsdaten und kennen für gewisse Eingabeparameter die gewünschten Ausgabewerte, nämlich Umsätze je Warengruppe. In der Trainingsphase berechnen wir den Fehler (die sogenannte “Loss”-Funktion) \(L\) aus der Differenz des berechneten Ausgabewertes zum erwarteten Umsatz.
Um den Fehler zu minimieren, müssen die Gewichte und Schwellwerte rückwirkend angepasst werden, man spricht hierbei von “backpropagation”, weil man nur die Schichten bis zurück zur Eingabeschicht durchwandert. Die nötige Anpassung der Gewichte und Schwellwerte berehnet man bspw. mithilfe des Gradienten der Loss-Funktionen in Bezug auf die postsynaptischen Potentiale. Ein Standard-Verfahren ist das Gradient-Descent-Verfahren. Werden zusätzlich die Gewichte und Schwellwerte mit zufälligen Werten initialisiert, spricht man vom Stochastic-Gradient-Descent-Verfahren (SGD). Bei diesem iterativen Lernalgorithmus versucht man den Fehler zu minimieren und sich so schrittweise an ein lokales oder sogar an das globale Minimum anzunähern. Neben SGD gibt es zahlreiche weitere Optimierungsstrategien.
Eine Erweiterung des klassischen SGD-Verfahrens ist “Adam”: Dabei wird nicht nur der aktuelle Gradient für die Anpassung der Gewichte und Schwellwerte herangezogen, sondern eine Sequenz von Gradienten. Wenn mehrere aufeinanderfolgende Anpassungen in die gleiche Richtung vorgenommen werden, erhöht sich somit die Lerngeschwindigkeit, man spricht von Lernen mit Momentum. Für klassisches SGD hingegen ist die Lernrate konstant.
Ein Modell wird üblicherweise über viele Epochen trainiert. In jeder Epoche kommt jeder Trainings-Input zum Einsatz. Die Anpassung der Gewichte und Schwellwerte kann nach jedem Input vorgenommen werden (“online learning”) oder erst am Ende einer Epoche, nachdem alle Ausgabewerte für alle Eingabekombinationen berechnet wurden (“batch learning”). In der Praxis verwendet man als Kompromiss häufig sogenannte mini-batches und verwendet dabei eine gewisse Anzahl an Trainings-Inputs, bevor die Gewichte und Schwellwerte angepasst werden.
Wir haben unsere neuronalen Netze in Python programmiert. Dabei verwenden wir das von Google entwickelte open-source Framework Tensonflow, das für die datenstromorientierte Programmierung konzipiert wurde und im Bereich Deep Learning weit verbreitet ist. Darüberhinaus verwenden wir Keras als open-source Deep-Learning-Bibliothek. Unser Quellcode befindet sich im Python-Skript MLP.py.
9.2 Datenaufbereitung
Wir arbeiten mit dem vollständigen Datensatz df_voll. Dieser enthält im Zeitraum 01.07.2013 bis 31.07.2019 eine Zeile für jedes Datum und jede Warengruppe. In den Rohdaten fehlende Umsätze sind auf Basis der Vorwochenwerte ergänzt worden. Die Zeilen mit ergänzten Umsätzen sind selektierbar über die Variable Umsatz_NA (= TRUE).
Für unser Vorhaben beschränken wir uns auf die in den Rohdaten vorhandenen Umsätze (Umsatz_NA = FALSE). Und wir schränken die Trainingsdaten später auf den Zeitraum 2015 bis 2017 ein, weil wir oben gesehen hatten, dass die Umsätze in 2014 systematisch höher liegen als in den folgenden Jahren. Die Umsätze des Jahres 2018 dienen uns dann als Testdaten.
Wir erstellen für diesen Abschnitt einen Analysedatensatz df_MLP auf Basis von df_voll.
df_MLP <- df_voll
# verwende nur originäre Umsatzdaten und grenze den Zeitraum auf 2015 bis 2018 ein
df_MLP <- df_MLP %>%
filter(Umsatz_NA == FALSE) %>%
filter(Jahr >= 2015 & Jahr <= 2018)
# behalte nur die Spalten, die wir für unser MLP verwenden wollen
df_MLP <- df_MLP %>%
dplyr::select(Datum, Jahr, Warengruppe, Umsatz, KielerWoche, Temperatur, Wochentag_c, SommerferienSH, Feiertag, Silvester_ext, Monat_c)
# Problem: Wir haben fehlende Temperatur-Werte. Filtere diese zunächst raus.
# sum(is.na(df_MLP$Temperatur))
df_MLP <- df_MLP %>% filter(!is.na(Temperatur))Im ersten Schritt verzichten wir auf die Variablen Windgeschwindigkeit und Bewölkung: Wir hatten nämlich in unserer Korrelationsanalyse gesehen, dass die Windgeschwindigkeit allenfalls einen sehr geringen Einfluss hat. Und die Bewölkung würde weitere 8 Dummyvariablen erfordern als Eingabe für unser MLP, daher verzichten wir darauf, um unser Modell nicht zu sehr aufzublähen.
Die Variablen Wochentag_c und Monat_c müssen nun noch dummyfiziert werden: Wir bilden für jeden Wochentag eine Variable mit Ausprägung 0/1. Und entfernen danach die alten Variablen Wochentag_c und Monat_c.
df_MLP <- df_MLP %>%
mutate(Montag=as.integer(df_MLP$Wochentag_c=="Montag")) %>%
mutate(Dienstag=as.integer(df_MLP$Wochentag_c=="Dienstag")) %>%
mutate(Mittwoch=as.integer(df_MLP$Wochentag_c=="Mittwoch")) %>%
mutate(Donnerstag=as.integer(df_MLP$Wochentag_c=="Donnerstag")) %>%
mutate(Freitag=as.integer(df_MLP$Wochentag_c=="Freitag")) %>%
mutate(Samstag=as.integer(df_MLP$Wochentag_c=="Samstag")) %>%
mutate(Sonntag=as.integer(df_MLP$Wochentag_c=="Sonntag")) %>%
dplyr::select(-Wochentag_c)
df_MLP <- df_MLP %>%
mutate(Januar=as.integer(df_MLP$Monat_c=="Januar")) %>%
mutate(Februar=as.integer(df_MLP$Monat_c=="Februar")) %>%
mutate(März=as.integer(df_MLP$Monat_c=="März")) %>%
mutate(April=as.integer(df_MLP$Monat_c=="April")) %>%
mutate(Mai=as.integer(df_MLP$Monat_c=="Mai")) %>%
mutate(Juni=as.integer(df_MLP$Monat_c=="Juni")) %>%
mutate(Juli=as.integer(df_MLP$Monat_c=="Juli")) %>%
mutate(August=as.integer(df_MLP$Monat_c=="August")) %>%
mutate(September=as.integer(df_MLP$Monat_c=="September")) %>%
mutate(Oktober=as.integer(df_MLP$Monat_c=="Oktober")) %>%
mutate(November=as.integer(df_MLP$Monat_c=="November")) %>%
mutate(Dezember=as.integer(df_MLP$Monat_c=="Dezember")) %>%
dplyr::select(-Monat_c)Als nächstes wollen wir noch die Temperatur-Variable dummyfizieren, indem wir sie in eine Binärvariable für 4 Intervallbereiche umwandeln. Hintergrund ist, dass die übrigen Input-Variablen bereits Binärvariablen sind und wir damit ein einheitliches Vorgehen für die Befütterung unseres kNN erreichen. Wir wählen die Intervalle und Bezeichnungen wie folgt:
- Temp_eis: < 0 Grad
- Temp_kalt: [0 bis 10 Grad)
- Temp_warm: [10 bis 20 Grad)
- Temp_heiss: >= 20 Grad
df_MLP <- df_MLP %>%
mutate(Temp_eis = as.integer(Temperatur<0)) %>%
mutate(Temp_kalt = as.integer(Temperatur>=0 & Temperatur<10)) %>%
mutate(Temp_warm = as.integer(Temperatur>=10 & Temperatur<20)) %>%
mutate(Temp_heiss = as.integer(Temperatur>=20)) %>%
dplyr::select(-Temperatur)Wir wandeln noch das Datum in eine Integerzahl um, weil wir sonst Probleme beim Import nach Python bekommen.
Für die Trainingsdaten verwenden wir den Zeitraum 2015 bis 2017 und für die Testdaten das Jahr 2018. Die Modellierung erfolgt je Warengruppe, daher teilen wir den Datensatz df_MLP auf.
df_MLP_train <- df_MLP %>% filter(Jahr < 2018)
df_MLP_test <- df_MLP %>% filter(Jahr == 2018)
df_MLP_train_WG1 <- df_MLP_train %>% filter(Warengruppe==1)
df_MLP_train_WG2 <- df_MLP_train %>% filter(Warengruppe==2)
df_MLP_train_WG3 <- df_MLP_train %>% filter(Warengruppe==3)
df_MLP_train_WG4 <- df_MLP_train %>% filter(Warengruppe==4)
df_MLP_train_WG5 <- df_MLP_train %>% filter(Warengruppe==5)
df_MLP_test_WG1 <- df_MLP_test %>% filter(Warengruppe==1)
df_MLP_test_WG2 <- df_MLP_test %>% filter(Warengruppe==2)
df_MLP_test_WG3 <- df_MLP_test %>% filter(Warengruppe==3)
df_MLP_test_WG4 <- df_MLP_test %>% filter(Warengruppe==4)
df_MLP_test_WG5 <- df_MLP_test %>% filter(Warengruppe==5)Das MLP wird in Python aufgebaut, daher exportieren wir die Trainings- und Testdatensätze für die verschiedenen Warengruppen als .csv. Wir verzichten beim Export auf die Zeilenüberschriften.
write_csv(df_MLP_train_WG1, path="data/df_MLP_train_WG1.csv", col_names=FALSE)
write_csv(df_MLP_train_WG2, path="data/df_MLP_train_WG2.csv", col_names=FALSE)
write_csv(df_MLP_train_WG3, path="data/df_MLP_train_WG3.csv", col_names=FALSE)
write_csv(df_MLP_train_WG4, path="data/df_MLP_train_WG4.csv", col_names=FALSE)
write_csv(df_MLP_train_WG5, path="data/df_MLP_train_WG5.csv", col_names=FALSE)
write_csv(df_MLP_test_WG1, path="data/df_MLP_test_WG1.csv", col_names=FALSE)
write_csv(df_MLP_test_WG2, path="data/df_MLP_test_WG2.csv", col_names=FALSE)
write_csv(df_MLP_test_WG3, path="data/df_MLP_test_WG3.csv", col_names=FALSE)
write_csv(df_MLP_test_WG4, path="data/df_MLP_test_WG4.csv", col_names=FALSE)
write_csv(df_MLP_test_WG5, path="data/df_MLP_test_WG5.csv", col_names=FALSE)9.3 Modellparameter
Modell 1 (MLP_mod1)
Im ersten Versuch bauen wir ein vergleichsweise kleines Modell und behalten nur die Variablen für SommerferienSH, Feiertag und Wochentage (Mo - So) als binäre Inputvariablen. Anders als bei der linearen Regression verwenden wir alle Wochentage. Wir haben also insgesamt 9 binäre Inputvariablen. Als output wollen wir den Umsatzschätzer erhalten und brauchen dafür im output layer nur eine Unit mit linearer Aktivierungsfunktion. Der Umsatz soll jedoch positiv sein, also verwenden wir eine “rectified linear unit” (relu).
Dazwischen liegt noch ein hidden layer mit 20 Units, hier verwenden wir die sigmoide Aktivierungsfunktion (sigmoid). Die Verwendung von mehr Einheiten im hidden layer brachte keine besseren Ergebnisse.
Als loss-Funktion verwenden wir standardmäßig den mean squared error (mse). Daneben verwenden wir stochastic gradient descent (SGD) als iterativen Lernalgorithmus mit einer Lernrate von 0.01. Auch hier brachte eine höhere oder niedrigere Lernrate keine besseren Ergebnisse.
Die Gewichte und Schwellwerte werden mit kleinen zufälligen Werten initialisiert unter Anwendung der Standard-Normalverteilung. Wir trainieren das einfache Modell über 50 Epochen, weil wir festgestellt haben, dass nach etwa 40 Epochen die loss-Parameter stabil bleiben. Und die batch-Größe setzen wir auf 10.
Modell 2 (MLP_mod2)
Im zweiten Schritt erweitern wir unser Modell und verwenden noch KielerWoche, Temperatur, Silvester_ext und Monat als Inputvariablen. Monat_c wurde dafür dummyfiziert. Und die Temperatur ist in 4 Bereiche und damit 4 Binärvariablen umgewandelt worden, damit wir einheitlich nur Binär-Inputs verwenden.
Insgesamt haben wir 27 Inputvariablen und erhöhen die Anzahl der Neuronen im hidden layer von 20 auf 50. Eine weitere Erhöhung liefert keine signifikant besseren Ergebnisse.
Im Training verwenden wir diesmal 100 Epochen, weil das komplexere Modell erst nach ca. 80 Epochen stabile loss-Werte zeigt.
9.4 Ergebnisse
Modell 1 (MLP_mod1)
Wir haben je ein Modell pro Warengruppe trainiert. Python liefert uns folgende finalen Parameter als train error:
| Modell | MSE | MAE |
|---|---|---|
| mod1_WG1 | 916 | 21.8 |
| mod1_WG2 | 6489 | 64.0 |
| mod1_WG3 | 2012 | 35.5 |
| mod1_WG4 | 845 | 20.2 |
| mod1_WG5 | 6891 | 44.8 |
Wenn wir in Python die trainierten Modelle auf die Testdaten anwenden, erhalten wir Umsatzschätzer je Warengruppe, die wir als csv hier einladen.
df_MLP_test_mod1_WG1_pred <- read_csv("data/df_MLP_test_mod1_WG1_pred.csv", col_names = FALSE)
df_MLP_test_mod1_WG2_pred <- read_csv("data/df_MLP_test_mod1_WG2_pred.csv", col_names = FALSE)
df_MLP_test_mod1_WG3_pred <- read_csv("data/df_MLP_test_mod1_WG3_pred.csv", col_names = FALSE)
df_MLP_test_mod1_WG4_pred <- read_csv("data/df_MLP_test_mod1_WG4_pred.csv", col_names = FALSE)
df_MLP_test_mod1_WG5_pred <- read_csv("data/df_MLP_test_mod1_WG5_pred.csv", col_names = FALSE)
colnames(df_MLP_test_mod1_WG1_pred) <- "Umsatz_mod1_WG1"
colnames(df_MLP_test_mod1_WG2_pred) <- "Umsatz_mod1_WG2"
colnames(df_MLP_test_mod1_WG3_pred) <- "Umsatz_mod1_WG3"
colnames(df_MLP_test_mod1_WG4_pred) <- "Umsatz_mod1_WG4"
colnames(df_MLP_test_mod1_WG5_pred) <- "Umsatz_mod1_WG5"Füge die Ergebnisse an die Test-Daten (für jede Warengruppe) und erstelle dann eine gemeinsame Übersichtstabelle für die Gütekennzahlen prog_MLP_vgl_kennz:
# mod1_WG1
df_MLP_test_mod1_WG1 <- cbind(df_MLP_test_WG1, df_MLP_test_mod1_WG1_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod1_WG1 <- df_MLP_test_mod1_WG1 %>%
mutate(Prognose_zuhoch = (Umsatz_mod1_WG1 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod1_WG1 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod1_WG1 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod1_WG1 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod1_WG1 <- df_MLP_test_mod1_WG1 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod1_WG1 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod1_WG1")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz <- temp
# mod1_WG2
df_MLP_test_mod1_WG2 <- cbind(df_MLP_test_WG2, df_MLP_test_mod1_WG2_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod1_WG2 <- df_MLP_test_mod1_WG2 %>%
mutate(Prognose_zuhoch = (Umsatz_mod1_WG2 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod1_WG2 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod1_WG2 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod1_WG2 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod1_WG2 <- df_MLP_test_mod1_WG2 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod1_WG2 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod1_WG2")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz <- rbind(prog_MLP_vgl_kennz, temp)
# mod1_WG3
df_MLP_test_mod1_WG3 <- cbind(df_MLP_test_WG3, df_MLP_test_mod1_WG3_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod1_WG3 <- df_MLP_test_mod1_WG3 %>%
mutate(Prognose_zuhoch = (Umsatz_mod1_WG3 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod1_WG3 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod1_WG3 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod1_WG3 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod1_WG3 <- df_MLP_test_mod1_WG3 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod1_WG3 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod1_WG3")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz <- rbind(prog_MLP_vgl_kennz, temp)
# mod1_WG4
df_MLP_test_mod1_WG4 <- cbind(df_MLP_test_WG4, df_MLP_test_mod1_WG4_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod1_WG4 <- df_MLP_test_mod1_WG4 %>%
mutate(Prognose_zuhoch = (Umsatz_mod1_WG4 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod1_WG4 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod1_WG4 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod1_WG4 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod1_WG4 <- df_MLP_test_mod1_WG4 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod1_WG4 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod1_WG4")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz <- rbind(prog_MLP_vgl_kennz, temp)
# mod1_WG5
df_MLP_test_mod1_WG5 <- cbind(df_MLP_test_WG5, df_MLP_test_mod1_WG5_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod1_WG5 <- df_MLP_test_mod1_WG5 %>%
mutate(Prognose_zuhoch = (Umsatz_mod1_WG5 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod1_WG5 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod1_WG5 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod1_WG5 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod1_WG5 <- df_MLP_test_mod1_WG5 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod1_WG5 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod1_WG5")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz <- rbind(prog_MLP_vgl_kennz, temp)
prog_MLP_vgl_kennz## # A tibble: 5 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738 132 26 -4 20 20 1422 38 29
## 2 346 130413 377 70 4 20 19 6733 82 22
## 3 346 59316 171 41 3 26 24 2694 52 30
## 4 345 28354 82 19 17 26 23 604 25 30
## 5 346 93912 271 63 19 25 23 9873 99 37
## # ... with 1 more variable: Modell <chr>
Das einfache Modell (mod1), das für die Umsatzschätzung nur SommerferienSH, Feiertag und Wochentage (Mo - So) als Inputvariablen einbezieht, liefert unterschiedliche Ergebnisse für die verschiedenen Warengruppen: Zunächst fällt auf, dass die mittlere relative Abweichung (MPE) für die Warengruppen 1, 2 und 3 nahe Null ist, während wir für die beiden Warengruppen 4 und 5 offenbar den Umsatz systematisch zu hoch schätzen.
Der gewichtete mittlere Absolutwert der relativen Abweichung (WAPE) zeigt für die Warengruppe 2 den niedrigsten Fehler. Wir hatten jedoch für das beste naive und lineare Schätzmodell einen deutlich niedrigeren Fehler gesehen für Warengruppe 2 (WAPE = 11). Und auch unser SVM-Modell lag für die Warengruppe in der Größenordnung.
Trotzdem wollen wir uns die Verteilung der relativen Abweichungen der Umsatzschätzung vom tatsächlichen Umsatz angucken und erstellen dafür eine weitere Vergleichstabelle prog_MLP_vgl_relAbw. Diese müssen wir dann noch pivotisieren (pivot_longer) als Vorbereitung auf den Boxplot:
# füge die relativen Abweichungen für WG1 an und benenne die Spalte um
prog_MLP_vgl_relAbw <- df_MLP_test_mod1_WG1 %>% dplyr::select(Datum, Abweichung_rel)
colnames(prog_MLP_vgl_relAbw)[2]="mod1_WG1"
# füge die relativen Abweichungen für WG2 an und benenne die Spalte um
prog_MLP_vgl_relAbw <- left_join(prog_MLP_vgl_relAbw, df_MLP_test_mod1_WG2 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_MLP_vgl_relAbw)[3]="mod1_WG2"
# füge die relativen Abweichungen für WG3 an und benenne die Spalte um
prog_MLP_vgl_relAbw <- left_join(prog_MLP_vgl_relAbw, df_MLP_test_mod1_WG3 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_MLP_vgl_relAbw)[4]="mod1_WG3"
# füge die relativen Abweichungen für WG4 an und benenne die Spalte um
prog_MLP_vgl_relAbw <- left_join(prog_MLP_vgl_relAbw, df_MLP_test_mod1_WG4 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_MLP_vgl_relAbw)[5]="mod1_WG4"
# füge die relativen Abweichungen für WG5 an und benenne die Spalte um
prog_MLP_vgl_relAbw <- left_join(prog_MLP_vgl_relAbw, df_MLP_test_mod1_WG5 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_MLP_vgl_relAbw)[6]="mod1_WG5"
# pivotisieren
prog_MLP_vgl_relAbw <- prog_MLP_vgl_relAbw %>%
pivot_longer(cols=-c("Datum"), names_to="Modell", values_to="Abweichung_rel")
# Boxplot
prog_MLP_vgl_relAbw %>%
ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
geom_boxplot() + coord_flip() +
ggtitle("2018 - Vergleich MLP Modell 1: Relative Abweichung") +
xlab("Modell_Warengruppe") +
ylab("rel. Abweichung (%)") +
ylim(-100, 200)## Warning: Removed 2 rows containing non-finite values (stat_boxplot).
Modell 2 (MLP_mod2)
Im zweiten Schritt erweitern wir unser Modell und verwenden noch KielerWoche, Temperatur, Silvester_ext und Monat als Inputvariablen. Monat_c wurde dafür dummyfiziert. Und die Temperatur ist in 4 Bereiche und damit 4 Binärvariablen umgewandelt worden, damit wir einheitlich nur Binär-Inputs verwenden.
Wir haben je ein Modell pro Warengruppe trainiert. Python liefert uns folgende finalen Parameter als train error:
| Modell | MSE | MAE |
|---|---|---|
| mod1_WG1 | 683 | 18.9 |
| mod1_WG2 | 2731 | 38.7 |
| mod1_WG3 | 851 | 21.6 |
| mod1_WG4 | 528 | 16.7 |
| mod1_WG5 | 1588 | 30.2 |
Wenn wir in Python die trainierten Modelle auf die Testdaten anwenden, erhalten wir Umsatzschätzer je Warengruppe, die wir als csv hier einladen.
df_MLP_test_mod2_WG1_pred <- read_csv("data/df_MLP_test_mod2_WG1_pred.csv", col_names = FALSE)
df_MLP_test_mod2_WG2_pred <- read_csv("data/df_MLP_test_mod2_WG2_pred.csv", col_names = FALSE)
df_MLP_test_mod2_WG3_pred <- read_csv("data/df_MLP_test_mod2_WG3_pred.csv", col_names = FALSE)
df_MLP_test_mod2_WG4_pred <- read_csv("data/df_MLP_test_mod2_WG4_pred.csv", col_names = FALSE)
df_MLP_test_mod2_WG5_pred <- read_csv("data/df_MLP_test_mod2_WG5_pred.csv", col_names = FALSE)
colnames(df_MLP_test_mod2_WG1_pred) <- "Umsatz_mod2_WG1"
colnames(df_MLP_test_mod2_WG2_pred) <- "Umsatz_mod2_WG2"
colnames(df_MLP_test_mod2_WG3_pred) <- "Umsatz_mod2_WG3"
colnames(df_MLP_test_mod2_WG4_pred) <- "Umsatz_mod2_WG4"
colnames(df_MLP_test_mod2_WG5_pred) <- "Umsatz_mod2_WG5"Füge die Ergebnisse an die Test-Daten (für jede Warengruppe) und erstelle dann eine gemeinsame Übersichtstabelle für die Gütekennzahlen prog_MLP_vgl_kennz_mod2:
# mod2_WG1
df_MLP_test_mod2_WG1 <- cbind(df_MLP_test_WG1, df_MLP_test_mod2_WG1_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod2_WG1 <- df_MLP_test_mod2_WG1 %>%
mutate(Prognose_zuhoch = (Umsatz_mod2_WG1 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod2_WG1 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod2_WG1 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod2_WG1 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod2_WG1 <- df_MLP_test_mod2_WG1 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod2_WG1 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod2_WG1")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz_mod2 <- temp
# mod2_WG2
df_MLP_test_mod2_WG2 <- cbind(df_MLP_test_WG2, df_MLP_test_mod2_WG2_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod2_WG2 <- df_MLP_test_mod2_WG2 %>%
mutate(Prognose_zuhoch = (Umsatz_mod2_WG2 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod2_WG2 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod2_WG2 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod2_WG2 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod2_WG2 <- df_MLP_test_mod2_WG2 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod2_WG2 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod2_WG2")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz_mod2 <- rbind(prog_MLP_vgl_kennz_mod2, temp)
# mod2_WG3
df_MLP_test_mod2_WG3 <- cbind(df_MLP_test_WG3, df_MLP_test_mod2_WG3_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod2_WG3 <- df_MLP_test_mod2_WG3 %>%
mutate(Prognose_zuhoch = (Umsatz_mod2_WG3 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod2_WG3 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod2_WG3 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod2_WG3 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod2_WG3 <- df_MLP_test_mod2_WG3 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod2_WG3 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod2_WG3")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz_mod2 <- rbind(prog_MLP_vgl_kennz_mod2, temp)
# mod2_WG4
df_MLP_test_mod2_WG4 <- cbind(df_MLP_test_WG4, df_MLP_test_mod2_WG4_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod2_WG4 <- df_MLP_test_mod2_WG4 %>%
mutate(Prognose_zuhoch = (Umsatz_mod2_WG4 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod2_WG4 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod2_WG4 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod2_WG4 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod2_WG4 <- df_MLP_test_mod2_WG4 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod2_WG4 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod2_WG4")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz_mod2 <- rbind(prog_MLP_vgl_kennz_mod2, temp)
# mod2_WG5
df_MLP_test_mod2_WG5 <- cbind(df_MLP_test_WG5, df_MLP_test_mod2_WG5_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod2_WG5 <- df_MLP_test_mod2_WG5 %>%
mutate(Prognose_zuhoch = (Umsatz_mod2_WG5 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod2_WG5 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod2_WG5 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod2_WG5 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod2_WG5 <- df_MLP_test_mod2_WG5 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
temp <- df_MLP_test_mod2_WG5 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# füge das Modell hinzu
temp <- temp %>% mutate(Modell = "mod2_WG5")
# füge die Kennzahlen nun an die Vergleichstabelle
prog_MLP_vgl_kennz_mod2 <- rbind(prog_MLP_vgl_kennz_mod2, temp)
prog_MLP_vgl_kennz_mod2## # A tibble: 5 x 11
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 45738 132 27 -4 21 20 1453 38 29
## 2 346 130413 377 46 7 13 12 3519 59 16
## 3 346 59316 171 34 -9 19 20 2051 45 26
## 4 345 28354 82 18 5 22 22 572 24 29
## 5 346 93912 271 43 -1 16 16 3367 58 21
## # ... with 1 more variable: Modell <chr>
Das erweiterte Modell (mod2) liefert im Gegensatz zum einfachen Modell (mod1) einheitlichere Ergebnisse für die verschiedenen Warengruppen: Zunächst fällt auf, dass die mittlere relative Abweichung (MPE) nun für die beiden Warengruppen 4 und 5 nahe Null liegt und sich unser Schätzer für die Warengruppen 2 und 3 leicht von Null entfernt haben.
Und der gewichtete mittlere Absolutwert der relativen Abweichung (WAPE) zeigt für die Warengruppen 2 und 5 die niedrigsten Fehler. Gleiches hatten wir bei den besten naiven und linearen Modellen sowie unserem SVM-Modell gefunden. Zum Vergleich: Für das beste naive Schätzmodell (glDS_4T_erw) hatten wir für Warengruppe 2 sogar einen etwas niedrigeren WAPE = 11 gesehen.
Als nächstes wollen wir uns die Verteilung der relativen Abweichungen der Umsatzschätzung vom tatsächlichen Umsatz angucken und erstellen dafür eine weitere Vergleichstabelle prog_MLP_vgl_relAbw_mod2. Diese müssen wir dann noch pivotisieren (pivot_longer) als Vorbereitung auf den Boxplot:
# füge die relativen Abweichungen für WG1 an und benenne die Spalte um
prog_MLP_vgl_relAbw_mod2 <- df_MLP_test_mod2_WG1 %>% dplyr::select(Datum, Abweichung_rel)
colnames(prog_MLP_vgl_relAbw_mod2)[2]="mod2_WG1"
# füge die relativen Abweichungen für WG2 an und benenne die Spalte um
prog_MLP_vgl_relAbw_mod2 <- left_join(prog_MLP_vgl_relAbw_mod2, df_MLP_test_mod2_WG2 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_MLP_vgl_relAbw_mod2)[3]="mod2_WG2"
# füge die relativen Abweichungen für WG3 an und benenne die Spalte um
prog_MLP_vgl_relAbw_mod2 <- left_join(prog_MLP_vgl_relAbw_mod2, df_MLP_test_mod2_WG3 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_MLP_vgl_relAbw_mod2)[4]="mod2_WG3"
# füge die relativen Abweichungen für WG4 an und benenne die Spalte um
prog_MLP_vgl_relAbw_mod2 <- left_join(prog_MLP_vgl_relAbw_mod2, df_MLP_test_mod2_WG4 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_MLP_vgl_relAbw_mod2)[5]="mod2_WG4"
# füge die relativen Abweichungen für WG5 an und benenne die Spalte um
prog_MLP_vgl_relAbw_mod2 <- left_join(prog_MLP_vgl_relAbw_mod2, df_MLP_test_mod2_WG5 %>% dplyr::select(Datum, Abweichung_rel),by="Datum")
colnames(prog_MLP_vgl_relAbw_mod2)[6]="mod2_WG5"
# pivotisieren
prog_MLP_vgl_relAbw_mod2 <- prog_MLP_vgl_relAbw_mod2 %>%
pivot_longer(cols=-c("Datum"), names_to="Modell", values_to="Abweichung_rel")
# Boxplot
prog_MLP_vgl_relAbw_mod2 %>%
ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
geom_boxplot() + coord_flip() +
ggtitle("2018 - Vergleich MLP Modell 2: Relative Abweichung") +
xlab("rel. Abweichung (%)") +
ylab("Dichte") +
ylim(-100, 200)## Warning: Removed 2 rows containing non-finite values (stat_boxplot).
Die Umsatzschätzung gelingt offenbar für die Warengruppe 2 (= Brötchen) ab besten.
9.5 Fazit DL Modelle
Wir haben in diesem Abschnitt zwei Multilayer Perceptron Modelle eingesetzt und genauer untersucht. Die Ergebnisse sind brauchbar aber nicht umwerfend. In beiden Modellen haben wir stochastic gradiend descent einen iterativen Lernalgorithmus verwendet, der keine Garantie gibt, das globale Optimum für die Gewichte und Schwellwerte zu finden. Das kann ein Grund für die mangelnde Ergebnis-Qualität sein.
Die Parameter - wie bspw. die Lernrate, die Anzahl der hidden layers und der Anzahl der Neuronen im hidden layer - haben wir empirisch festgelegt. Hierfür gibt es keine “optimalen Werte”.
Insgesamt stellen wir fest, dass die so gebauten MLP Modelle dem Problem nicht gerecht werden. Vermutlich würde man mit rekursiven Netzen und/oder dem Einsatz von long-short-term-memory (LSTM) Einheiten deutlich bessere Ergebnisse erzielen. Das sprengt jedoch den Umfang dieser Projektarbeit und wird daher nicht weiter betrachtet.
Wir hatten gesehen, dass das komplexe Modell (mod2) für die Warengruppe 2 in Bezug auf den WAPE gute Ergebnisse liefert. Ein Ansatz ist, das Modell gezielt für diese Warengruppe noch zu erweitern. Hier haben wir versucht, einen zweiten hidden layer mit 20 Einheiten in das Modell zu integrieren. Allerdings verschlechterten sich dadurch die Prognose-Ergebnisse, so dass wir den Ansatz nicht weiter verfolgt haben. Alternativ haben wir ein Kompromiss-Modell (mod3) getestet, das nur die Variablen SommerferienSH, Feiertag, Silvester_ext, Samstag, Sonntag, Juli und August enthält. Und dieses Modell haben wir versucht, für Warengruppe 2 zu optimieren durch Variation der Units im hidden layer, Anwendung anderer Lernalgorithmen (Adam) oder Hinzunahme eines weiteren hidden layers - ohne Erfolg.
Auch könnte man das Modell gezielt auf die Feiertags-Effekte trainieren, um dafür bessere Ergebnisse zu erzielen. Diese Idee stellt eine Ausbaustufe dar, die wir hier nicht umgesetzt haben.
Insgesamt ging es hier eher darum, Erfahrungswerte in der praktischen Anwendung von DL-Verfahren zu sammeln und das ist in der Tat sehr gut gelungen.
9.6 Zugabe
Weil wir uns vom MLP bessere Ergebnisse erhofft hatten, haben wir noch einen drauf gesetzt und noch ein viertes MLP (mod4) getestet. Dafür haben wir den vollständigen SVM-Datensatz verwendet mit allen Inputvariablen und skalierten Wettervariablen sowie skaliertem Umsatz.
Getestet haben wir wieder sequentielle MLP-Modelle, diesmal aber gezielt mit mehreren hidden layers. Die besten Ergebnisse lieferte ein Modell mit zwei hidden layers, bestehend aus 100 bzw. 50 Einheiten, jeweils mit ‘relu’ Aktivierungsfunktionen. Als Lernalgorithmus haben wir dabei ‘Adam’ angewendet mit einer Lernrate von 0.001, gleichzeitig haben wir online learning (batch_size = 1) angewendet und das Modell über 20 Epochen trainiert.
Diese Parametereinstellungen lieferten die besten Ergebnisse (df_MLP_test_mod4_WG2_pred.csv). Verlängert man die Trainingsphase um weitere 20 Epochen (df_MLP_test_mod4_WG2_pred2.csv), verschlechtert sich die Prognosegüte bei Anwendung des Modells auf die Testdaten. Ein dritter hidden layer mit 25 Einheiten (df_MLP_test_mod4_WG2_pred3.csv) bringt keinen Mehrwert. Und auch wenn man die Anzahl der Einheiten im ersten hidden layer verdoppelt (df_MLP_test_mod4_WG2_pred4.csv), erzielt man keine genaueren Schätzwerte.
Hier die Testergebnisse - exemplarisch für Warengruppe 2:
df_MLP_test_mod4_WG2_pred <- read_csv("data/df_MLP_test_mod4_WG2_pred.csv", col_names = FALSE)
colnames(df_MLP_test_mod4_WG2_pred) <- "Umsatz_mod4_WG2"Füge die Ergebnisse an die Test-Daten und bilde die Gütekennzahlen. Vorher müssen wir den Umsatz wieder zurück skalieren:
# mod1_WG1
df_MLP_test_mod4_WG2 <- cbind(df_SVM_test_WG2, df_MLP_test_mod4_WG2_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod4_WG2 <- df_MLP_test_mod4_WG2 %>%
# mutate(Umsatz = Umsatz * 2000) %>%
# Hinweis: Wir hatten ursprünglich den Umsatz im Kapitel SVM skaliert und auf der Basis
# unser MLP (mod4) trainiert. Nachträglich haben wir die Skalierung für den
# df_SVM_test_WG2 wieder raus genommen. Dennoch enthalten die Modellergebnisse aus Python
# den skalierten Umsatz und müssen wieder re-skaliert werden:
mutate(Umsatz_mod4_WG2 = Umsatz_mod4_WG2 * 2000) %>%
mutate(Prognose_zuhoch = (Umsatz_mod4_WG2 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod4_WG2 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod4_WG2 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod4_WG2 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod4_WG2 <- df_MLP_test_mod4_WG2 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
df_MLP_test_mod4_WG2 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))## # A tibble: 1 x 10
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 346 130413 377 39 2 11 10 2594 51 14
Der WAPE liegt bei 10 und liegt damit knapp unterhalb des besten naiven und linearen Modells, sowie des SVM-Modells. Das hat uns ermutigt, Modell 4 auf eine andere Warengruppe anzuwenden.
Hier die Ergebnisse für Warengruppe 4:
df_MLP_test_mod4_WG4_pred <- read_csv("data/df_MLP_test_mod4_WG4_pred.csv", col_names = FALSE)
colnames(df_MLP_test_mod4_WG4_pred) <- "Umsatz_mod4_WG4"Füge die Ergebnisse an die Test-Daten und bilde die Gütekennzahlen. VORHER den Umsatz wieder zurück skalieren:
# mod1_WG1
df_MLP_test_mod4_WG4 <- cbind(df_SVM_test_WG4, df_MLP_test_mod4_WG4_pred)
# ergänze Prognose_zuhoch (TRUE / FALSE), Abweichung (Schätzer - Umsatz), absolute Abweichung (Abweichung_abs), relative Abweichung (Abweichung_rel), quadratische Abweichung (Abweichung_quad)
df_MLP_test_mod4_WG4 <- df_MLP_test_mod4_WG4 %>%
# mutate(Umsatz = Umsatz * 2000) %>%
# Hinweis: Wir hatten ursprünglich den Umsatz im Kapitel SVM skaliert und auf der Basis
# unser MLP (mod4) trainiert. Nachträglich haben wir die Skalierung für den
# df_SVM_test_WG4 wieder raus genommen. Dennoch enthalten die Modellergebnisse aus Python
# den skalierten Umsatz und müssen wieder re-skaliert werden:
mutate(Umsatz_mod4_WG4 = Umsatz_mod4_WG4 * 2000) %>%
mutate(Prognose_zuhoch = (Umsatz_mod4_WG4 >= Umsatz)) %>%
mutate(Abweichung = Umsatz_mod4_WG4 - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_mod4_WG4 - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_mod4_WG4 - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# Ergänze die benötigten Hilfsgrößen
df_MLP_test_mod4_WG4 <- df_MLP_test_mod4_WG4 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# Prognosegüte: mittlere Abweichung, mittlere absolute / relative Abweichung, mittlere quadratische Abweichung
df_MLP_test_mod4_WG4 %>%
group_by() %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))## # A tibble: 1 x 10
## Anzahl Umsatz_ges Umsatz_mittel MAE MPE MAPE WAPE MSE RMSE rRMSE
## <int> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 345 28354 82 19 13 25 23 741 27 33
Unsere Hoffnung hat sich jedoch nicht erfüllt: Der WAPE ist schlechter als für das einfachere Modell 2 (mod2) für die Warengruppe 4.
10 Modellvergleich
Wir wollen nun eine Gesamttabelle aller Vergleichskennzahlen erstellen. Wir beschränken uns dabei auf die Anwendung der Modelle auf die Testdaten, betrachten also die Testfehler.
Wir hatten fünf verschiedene Verfahren angewendet: Naive Modelle (“naiv”), lineare Regressionsmodelle (“lm”), Entscheidungsbäume (“DT”), Support Vector Machines (“SVM”) und Multilayer Perceptrons (“MLP”).
Innerhalb der Verfahren haben wir bereits die besten Modelle identifiziert:
- Bei den naiven Modellen lieferte der erweiterte gleitende Durchschnitt der letzten 4 Wochen- bzw. Wochenendtage (glDS_4T_erw) die besten Schätzer.
- Für die linearen Regressionsmodelle hatten wir gesehen, dass die Modelle mit 21 (best21), 24 (best24), 30 (best30), 1 (best1) und 8 (best8) die besten Schätzer für die Warengruppen 1 bis 5 lieferten.
- Bei den Entscheidungsbäumen (bzw. Regression trees) hatten wir für jede Warengruppe (WG1 bis WG5) ein optimales Modell berchnet.
- Bei den Support Vector Machines hatten wir für jede Warengruppe genau ein Modell (WG1 bis WG5) optimiert.
- Und bei den Multilayer Perceptronen hatten wir mit Modell 2 (mod2) gute Ergebnisse erzielt. Und für die Warengruppe 2 hatte unser Zugabe-Modell (mod4) die besten Ergebnisse geliefert.
Die besten Modelle werden nun für alle Warengruppen in einer Tabelle modell_vergleich_WG zusammengestellt.
# bestes naives Modell
temp <- prog_naiv_glDS_4T_erw %>%
mutate(Verfahren="naiv") %>%
mutate(Modell="glDS_4T_erw") %>%
group_by(Verfahren, Modell, Warengruppe) %>%
filter(Jahr==2018) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- temp
# bestes lineares Modell: WG1
temp <- df_lm_test_WG1_21 %>%
mutate(Verfahren="lm") %>%
mutate(Modell="best21") %>%
mutate(Warengruppe=1) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bestes lineares Modell: WG2
temp <- df_lm_test_WG2_24 %>%
mutate(Verfahren="lm") %>%
mutate(Modell="best24") %>%
mutate(Warengruppe=2) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bestes lineares Modell: WG3
temp <- df_lm_test_WG3_30 %>%
mutate(Verfahren="lm") %>%
mutate(Modell="best30") %>%
mutate(Warengruppe=3) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bestes lineares Modell: WG4
temp <- df_lm_test_WG4_1 %>%
mutate(Verfahren="lm") %>%
mutate(Modell="best1") %>%
mutate(Warengruppe=4) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bestes lineares Modell: WG5
temp <- df_lm_test_WG5_8 %>%
mutate(Verfahren="lm") %>%
mutate(Modell="best8") %>%
mutate(Warengruppe=5) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bester Entscheidungsbaum: WG1
temp <- df_dt_test_WG1 %>%
mutate(Verfahren="DT") %>%
mutate(Modell="WG1") %>%
mutate(Warengruppe=1) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bester Entscheidungsbaum: WG2
temp <- df_dt_test_WG2 %>%
mutate(Verfahren="DT") %>%
mutate(Modell="WG2") %>%
mutate(Warengruppe=2) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bester Entscheidungsbaum: WG3
temp <- df_dt_test_WG3 %>%
mutate(Verfahren="DT") %>%
mutate(Modell="WG32") %>%
mutate(Warengruppe=3) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bester Entscheidungsbaum: WG4
temp <- df_dt_test_WG4 %>%
mutate(Verfahren="DT") %>%
mutate(Modell="WG4") %>%
mutate(Warengruppe=4) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bester Entscheidungsbaum: WG5
temp <- df_dt_test_WG5 %>%
mutate(Verfahren="DT") %>%
mutate(Modell="WG5") %>%
mutate(Warengruppe=5) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bestes SVM Modell: WG1
temp <- df_SVM_test_WG1 %>%
mutate(Verfahren="SVM") %>%
mutate(Modell="WG1") %>%
mutate(Warengruppe=1) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bestes SVM Modell: WG2
temp <- df_SVM_test_WG2 %>%
mutate(Verfahren="SVM") %>%
mutate(Modell="WG2") %>%
mutate(Warengruppe=2) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bestes SVM Modell: WG3
temp <- df_SVM_test_WG3 %>%
mutate(Verfahren="SVM") %>%
mutate(Modell="WG3") %>%
mutate(Warengruppe=3) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bestes SVM Modell: WG4
temp <- df_SVM_test_WG4 %>%
mutate(Verfahren="SVM") %>%
mutate(Modell="WG4") %>%
mutate(Warengruppe=4) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bestes SVM Modell: WG5
temp <- df_SVM_test_WG5 %>%
mutate(Verfahren="SVM") %>%
mutate(Modell="WG5") %>%
mutate(Warengruppe=5) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bestes MLP Modell: WG1
temp <- df_MLP_test_mod2_WG1 %>%
mutate(Verfahren="MLP") %>%
mutate(Modell="mod2") %>%
mutate(Warengruppe=1) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bestes MLP Modell: WG2
temp <- df_MLP_test_mod4_WG2 %>%
mutate(Verfahren="MLP") %>%
mutate(Modell="mod4") %>%
mutate(Warengruppe=2) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bestes MLP Modell: WG3
temp <- df_MLP_test_mod2_WG3 %>%
mutate(Verfahren="MLP") %>%
mutate(Modell="mod2") %>%
mutate(Warengruppe=3) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bestes MLP Modell: WG4
temp <- df_MLP_test_mod2_WG4 %>%
mutate(Verfahren="MLP") %>%
mutate(Modell="mod2") %>%
mutate(Warengruppe=4) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp)
# bestes MLP Modell: WG5
temp <- df_MLP_test_mod2_WG5 %>%
mutate(Verfahren="MLP") %>%
mutate(Modell="mod2") %>%
mutate(Warengruppe=5) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen der Ergebnisse an die Vergleichstabelle
modell_vergleich_WG <- rbind(modell_vergleich_WG, temp) Jetzt wollen wir für jede Warengruppe prüfen, welches Verfahren mit welchem Modell die besten Prognosen liefert. Und zwar bewerten wir das anhand der folgenden drei Gütekennzahlen:
- MPE (Mean Percentage Error): Die mittlere relative Abweichung gibt uns ein Indiz dafür, ob unser Modell die Umsätze systematisch zu hoch oder zu niedrig schätzt. Wir wollen natürlich möglichst einen Mittelwert nahe Null erzielen. Falls ein Modell jedoch den Umsatz systematisch zu hoch oder zu niedrig schätzt und ansonsten hervoragende Gütekennzahlen aufweist, kann man die Schätzwerte mit einem Offset korrigieren um eben diese mittlere relative Abweichung.
- WAPE (Weighted Absolute Percent Error): Der gewichtete Mittelwert des Absolutwertes der relativen Abweichung ist für das wichtigste Bewertungskriterium, weil es die Prognosegüte insgesamt am besten misst. Dabei gilt: Je kleiner, desto besser.
- rRMSE (relative Root Mean Square Error): Der Mittelwert der Wurzel der quadratischen Abweichung - ins Verhältnis gesetzt zum mittleren Umsatz - liefert uns Anhaltspunkte, ob vermehrt größere Abweichungen zwischen geschätztem und tatsächlichem Umsatz vorliegen. Wir wollen also hier möglichst niedrige Werte finden.
## # A tibble: 5 x 13
## # Groups: Verfahren, Modell [5]
## Verfahren Modell Warengruppe Anzahl Umsatz_ges Umsatz_mittel MAE MPE
## <chr> <chr> <dbl> <int> <dbl> <dbl> <dbl> <dbl>
## 1 lm best21 1 346 45738 132 25 -8
## 2 SVM WG1 1 346 45738 132 25 -6
## 3 MLP mod2 1 346 45738 132 27 -4
## 4 DT WG1 1 346 45738 132 28 -6
## 5 naiv glDS_~ 1 358 47292 132 30 9
## # ... with 5 more variables: MAPE <dbl>, WAPE <dbl>, MSE <dbl>,
## # RMSE <dbl>, rRMSE <dbl>
Für die Warengruppe 1 liefert das lineare Modell insgesamt betrachtet den besten Schätzer. MAPE, WAPE und rRMSE sind bei diesem Modell am niedrigsten. Der MPE ist zwar am zweitschlechtesten, doch wie angeführt, könnte man die Schätzwerte mit einem Offset korrigieren.
## # A tibble: 5 x 13
## # Groups: Verfahren, Modell [5]
## Verfahren Modell Warengruppe Anzahl Umsatz_ges Umsatz_mittel MAE MPE
## <chr> <chr> <dbl> <int> <dbl> <dbl> <dbl> <dbl>
## 1 MLP mod4 2 346 130413 377 39 2
## 2 naiv glDS_~ 2 358 135858 379 41 1
## 3 lm best24 2 346 130413 377 40 3
## 4 SVM WG2 2 346 130413 377 42 2
## 5 DT WG2 2 346 130413 377 50 4
## # ... with 5 more variables: MAPE <dbl>, WAPE <dbl>, MSE <dbl>,
## # RMSE <dbl>, rRMSE <dbl>
Für Warengruppe 2 liefern alle Modelle relativ gute Ergebnisse. Das MLP Modell (mod4) hat knapp die Nase vorn.
## # A tibble: 5 x 13
## # Groups: Verfahren, Modell [5]
## Verfahren Modell Warengruppe Anzahl Umsatz_ges Umsatz_mittel MAE MPE
## <chr> <chr> <dbl> <int> <dbl> <dbl> <dbl> <dbl>
## 1 naiv glDS_~ 3 358 61867 173 26 3
## 2 lm best30 3 346 59316 171 31 -8
## 3 SVM WG3 3 346 59316 171 32 -7
## 4 MLP mod2 3 346 59316 171 34 -9
## 5 DT WG32 3 346 59316 171 36 -7
## # ... with 5 more variables: MAPE <dbl>, WAPE <dbl>, MSE <dbl>,
## # RMSE <dbl>, rRMSE <dbl>
Für Warengruppe 3 gewinnt sehr deutlich das naive Modell.
## # A tibble: 5 x 13
## # Groups: Verfahren, Modell [5]
## Verfahren Modell Warengruppe Anzahl Umsatz_ges Umsatz_mittel MAE MPE
## <chr> <chr> <dbl> <int> <dbl> <dbl> <dbl> <dbl>
## 1 naiv glDS_~ 4 357 29606 83 17 5
## 2 DT WG4 4 345 28354 82 17 6
## 3 lm best1 4 345 28354 82 18 14
## 4 MLP mod2 4 345 28354 82 18 5
## 5 SVM WG4 4 345 28354 82 19 14
## # ... with 5 more variables: MAPE <dbl>, WAPE <dbl>, MSE <dbl>,
## # RMSE <dbl>, rRMSE <dbl>
Für Warengruppe 4 gewinnt wieder das naive Modell, wenngleich auch der DT und das MLP gut performen. Bei diesen Modellen ist jedoch ein vergleichsweise hoher rRMSE zu beobachten.
## # A tibble: 5 x 13
## # Groups: Verfahren, Modell [5]
## Verfahren Modell Warengruppe Anzahl Umsatz_ges Umsatz_mittel MAE MPE
## <chr> <chr> <dbl> <int> <dbl> <dbl> <dbl> <dbl>
## 1 lm best8 5 346 93912 271 39 1
## 2 DT WG5 5 346 93912 271 41 0
## 3 naiv glDS_~ 5 358 97639 273 43 2
## 4 SVM WG5 5 346 93912 271 43 0
## 5 MLP mod2 5 346 93912 271 43 -1
## # ... with 5 more variables: MAPE <dbl>, WAPE <dbl>, MSE <dbl>,
## # RMSE <dbl>, rRMSE <dbl>
Für Warengruppe 5 gewinnt das lineare Modell, gefolgt vom DT, der jedoch einen deutlich schlechteren rRMSE aufweist.
11 Ensemble Methoden
Wir haben im letzten Abschnitt für jede Warengruppe die besten Einzelmodelle der verschiedenen Verfahren identifiziert. Als nächsten wollen wir eine Kombination dieser besten Einzelmodelle - ein sogenanntes Ensemble - bilden, in der Hoffnung, dass sich dadurch noch bessere Prognosen erstellen lassen.
Zuerst stellen wir die Schätzer in einer gemeinsamen Tabelle zusammen, wobei wir eine Tabelle je Warengruppe bilden. Die Basis bilden die Ergebnisse des besten naiven Modells (glDS_4T_erw).
# Warengruppe 1
# bestes naives Modell
ensemble_WG1 <- prog_naiv_glDS_4T_erw %>%
group_by() %>%
na.omit() %>%
filter(Jahr == 2018 & Warengruppe == 1 & Umsatz_NA == FALSE) %>%
dplyr::select(Datum, Warengruppe, Umsatz, Umsatz_glDS_4T_erw) %>%
mutate(Umsatz_naiv = Umsatz_glDS_4T_erw) %>%
dplyr::select(-Umsatz_glDS_4T_erw)
# bestes lineares Modell
temp <- df_lm_test_WG1_21 %>%
dplyr::select(predicted) %>%
mutate(Umsatz_lm = predicted) %>%
dplyr::select(-predicted)
# Anfügen ans Ensemble
ensemble_WG1 <- cbind(ensemble_WG1, temp)
# bester DT
temp <- df_dt_test_WG1 %>%
dplyr::select(predicted) %>%
mutate(Umsatz_dt = predicted) %>%
dplyr::select(-predicted)
# Anfügen ans Ensemble
ensemble_WG1 <- cbind(ensemble_WG1, temp)
# bestes SVM Modell
temp <- df_SVM_test_WG1 %>%
dplyr::select(Umsatz_WG1) %>%
mutate(Umsatz_SVM = Umsatz_WG1) %>%
dplyr::select(-Umsatz_WG1)
# Anfügen ans Ensemble
ensemble_WG1 <- cbind(ensemble_WG1, temp)
# bestes MLP Modell
temp <- df_MLP_test_mod2_WG1 %>%
dplyr::select(Umsatz_mod2_WG1) %>%
mutate(Umsatz_MLP = Umsatz_mod2_WG1) %>%
dplyr::select(-Umsatz_mod2_WG1)
# Anfügen ans Ensemble
ensemble_WG1 <- cbind(ensemble_WG1, temp)
# Warengruppe 2
# bestes naives Modell
ensemble_WG2 <- prog_naiv_glDS_4T_erw %>%
group_by() %>%
na.omit() %>%
filter(Jahr == 2018 & Warengruppe == 2 & Umsatz_NA == FALSE) %>%
dplyr::select(Datum, Warengruppe, Umsatz, Umsatz_glDS_4T_erw) %>%
mutate(Umsatz_naiv = Umsatz_glDS_4T_erw) %>%
dplyr::select(-Umsatz_glDS_4T_erw)
# bestes lineares Modell
temp <- df_lm_test_WG2_24 %>%
dplyr::select(predicted) %>%
mutate(Umsatz_lm = predicted) %>%
dplyr::select(-predicted)
# Anfügen ans Ensemble
ensemble_WG2 <- cbind(ensemble_WG2, temp)
# bester DT
temp <- df_dt_test_WG2 %>%
dplyr::select(predicted) %>%
mutate(Umsatz_dt = predicted) %>%
dplyr::select(-predicted)
# Anfügen ans Ensemble
ensemble_WG2 <- cbind(ensemble_WG2, temp)
# bestes SVM Modell
temp <- df_SVM_test_WG2 %>%
dplyr::select(Umsatz_WG2) %>%
mutate(Umsatz_SVM = Umsatz_WG2) %>%
dplyr::select(-Umsatz_WG2)
# Anfügen ans Ensemble
ensemble_WG2 <- cbind(ensemble_WG2, temp)
# bestes MLP Modell
temp <- df_MLP_test_mod4_WG2 %>%
dplyr::select(Umsatz_mod4_WG2) %>%
mutate(Umsatz_MLP = Umsatz_mod4_WG2) %>%
dplyr::select(-Umsatz_mod4_WG2)
# Anfügen ans Ensemble
ensemble_WG2 <- cbind(ensemble_WG2, temp)
# Warengruppe 3
# bestes naives Modell
ensemble_WG3 <- prog_naiv_glDS_4T_erw %>%
group_by() %>%
na.omit() %>%
filter(Jahr == 2018 & Warengruppe == 3 & Umsatz_NA == FALSE) %>%
dplyr::select(Datum, Warengruppe, Umsatz, Umsatz_glDS_4T_erw) %>%
mutate(Umsatz_naiv = Umsatz_glDS_4T_erw) %>%
dplyr::select(-Umsatz_glDS_4T_erw)
# bestes lineares Modell
temp <- df_lm_test_WG3_30 %>%
dplyr::select(predicted) %>%
mutate(Umsatz_lm = predicted) %>%
dplyr::select(-predicted)
# Anfügen ans Ensemble
ensemble_WG3 <- cbind(ensemble_WG3, temp)
# bester DT
temp <- df_dt_test_WG3 %>%
dplyr::select(predicted) %>%
mutate(Umsatz_dt = predicted) %>%
dplyr::select(-predicted)
# Anfügen ans Ensemble
ensemble_WG3 <- cbind(ensemble_WG3, temp)
# bestes SVM Modell
temp <- df_SVM_test_WG3 %>%
dplyr::select(Umsatz_WG3) %>%
mutate(Umsatz_SVM = Umsatz_WG3) %>%
dplyr::select(-Umsatz_WG3)
# Anfügen ans Ensemble
ensemble_WG3 <- cbind(ensemble_WG3, temp)
# bestes MLP Modell
temp <- df_MLP_test_mod2_WG3 %>%
dplyr::select(Umsatz_mod2_WG3) %>%
mutate(Umsatz_MLP = Umsatz_mod2_WG3) %>%
dplyr::select(-Umsatz_mod2_WG3)
# Anfügen ans Ensemble
ensemble_WG3 <- cbind(ensemble_WG3, temp)
# Warengruppe 4
# bestes naives Modell
ensemble_WG4 <- prog_naiv_glDS_4T_erw %>%
group_by() %>%
na.omit() %>%
filter(Jahr == 2018 & Warengruppe == 4 & Umsatz_NA == FALSE) %>%
dplyr::select(Datum, Warengruppe, Umsatz, Umsatz_glDS_4T_erw) %>%
mutate(Umsatz_naiv = Umsatz_glDS_4T_erw) %>%
dplyr::select(-Umsatz_glDS_4T_erw)
# bestes lineares Modell
temp <- df_lm_test_WG4_1 %>%
dplyr::select(predicted) %>%
mutate(Umsatz_lm = predicted) %>%
dplyr::select(-predicted)
# Anfügen ans Ensemble
ensemble_WG4 <- cbind(ensemble_WG4, temp)
# bester DT
temp <- df_dt_test_WG4 %>%
dplyr::select(predicted) %>%
mutate(Umsatz_dt = predicted) %>%
dplyr::select(-predicted)
# Anfügen ans Ensemble
ensemble_WG4 <- cbind(ensemble_WG4, temp)
# bestes SVM Modell
temp <- df_SVM_test_WG4 %>%
dplyr::select(Umsatz_WG4) %>%
mutate(Umsatz_SVM = Umsatz_WG4) %>%
dplyr::select(-Umsatz_WG4)
# Anfügen ans Ensemble
ensemble_WG4 <- cbind(ensemble_WG4, temp)
# bestes MLP Modell
temp <- df_MLP_test_mod2_WG4 %>%
dplyr::select(Umsatz_mod2_WG4) %>%
mutate(Umsatz_MLP = Umsatz_mod2_WG4) %>%
dplyr::select(-Umsatz_mod2_WG4)
# Anfügen ans Ensemble
ensemble_WG4 <- cbind(ensemble_WG4, temp)
# Warengruppe 5
# bestes naives Modell
ensemble_WG5 <- prog_naiv_glDS_4T_erw %>%
group_by() %>%
na.omit() %>%
filter(Jahr == 2018 & Warengruppe == 5 & Umsatz_NA == FALSE) %>%
dplyr::select(Datum, Warengruppe, Umsatz, Umsatz_glDS_4T_erw) %>%
mutate(Umsatz_naiv = Umsatz_glDS_4T_erw) %>%
dplyr::select(-Umsatz_glDS_4T_erw)
# bestes lineares Modell
temp <- df_lm_test_WG5_8 %>%
dplyr::select(predicted) %>%
mutate(Umsatz_lm = predicted) %>%
dplyr::select(-predicted)
# Anfügen ans Ensemble
ensemble_WG5 <- cbind(ensemble_WG5, temp)
# bester DT
temp <- df_dt_test_WG5 %>%
dplyr::select(predicted) %>%
mutate(Umsatz_dt = predicted) %>%
dplyr::select(-predicted)
# Anfügen ans Ensemble
ensemble_WG5 <- cbind(ensemble_WG5, temp)
# bestes SVM Modell
temp <- df_SVM_test_WG5 %>%
dplyr::select(Umsatz_WG5) %>%
mutate(Umsatz_SVM = Umsatz_WG5) %>%
dplyr::select(-Umsatz_WG5)
# Anfügen ans Ensemble
ensemble_WG5 <- cbind(ensemble_WG5, temp)
# bestes MLP Modell
temp <- df_MLP_test_mod2_WG5 %>%
dplyr::select(Umsatz_mod2_WG5) %>%
mutate(Umsatz_MLP = Umsatz_mod2_WG5) %>%
dplyr::select(-Umsatz_mod2_WG5)
# Anfügen ans Ensemble
ensemble_WG5 <- cbind(ensemble_WG5, temp)Wir bilden nun den Ensemble-Schätzer als Mittelwert der besten Einzelschätzer. Anschließend ermitteln wir die Gütekennzahlen. Die Ergebnisse für die Warengruppen sammeln wir in einer gemeinsamen Tabelle ensemble_WG_vgl.
# Warengruppe 1
# bilde Ensemble-Umsatz
ensemble_WG1 <- ensemble_WG1 %>%
mutate(Umsatz_ensemble = (Umsatz_naiv + Umsatz_lm + Umsatz_dt + Umsatz_SVM + Umsatz_MLP) / 5)
# bilde Hilfsgrößen für die spätere Ermittlung der Gütemaße
ensemble_WG1 <- ensemble_WG1 %>%
mutate(Prognose_zuhoch = (Umsatz_ensemble >= Umsatz)) %>%
mutate(Abweichung = Umsatz_ensemble - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_ensemble - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_ensemble - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# ergänze die Anzahl
ensemble_WG1 <- ensemble_WG1 %>%
group_by(Warengruppe) %>%
mutate(Anzahl = n())
# ergänze eine weitere Hilfsgröße
ensemble_WG1 <- ensemble_WG1 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# ermittle die Gütemaße
ensemble_WG_vgl <- ensemble_WG1 %>%
group_by() %>%
mutate(Verfahren="Ensemble") %>%
mutate(Modell="MW") %>%
mutate(Warengruppe=1) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Warengruppe 2
# bilde Ensemble-Umsatz
ensemble_WG2 <- ensemble_WG2 %>%
mutate(Umsatz_ensemble = (Umsatz_naiv + Umsatz_lm + Umsatz_dt + Umsatz_SVM + Umsatz_MLP) / 5)
# bilde Hilfsgrößen für die spätere Ermittlung der Gütemaße
ensemble_WG2 <- ensemble_WG2 %>%
mutate(Prognose_zuhoch = (Umsatz_ensemble >= Umsatz)) %>%
mutate(Abweichung = Umsatz_ensemble - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_ensemble - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_ensemble - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# ergänze die Anzahl
ensemble_WG2 <- ensemble_WG2 %>%
group_by(Warengruppe) %>%
mutate(Anzahl = n())
# ergänze eine weitere Hilfsgröße
ensemble_WG2 <- ensemble_WG2 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# ermittle die Gütemaße
temp <- ensemble_WG2 %>%
group_by() %>%
mutate(Verfahren="Ensemble") %>%
mutate(Modell="MW") %>%
mutate(Warengruppe=2) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen an Vergleichstabelle
ensemble_WG_vgl <- rbind(ensemble_WG_vgl, temp)
# Warengruppe 3
# bilde Ensemble-Umsatz
ensemble_WG3 <- ensemble_WG3 %>%
mutate(Umsatz_ensemble = (Umsatz_naiv + Umsatz_lm + Umsatz_dt + Umsatz_SVM + Umsatz_MLP) / 5)
# bilde Hilfsgrößen für die spätere Ermittlung der Gütemaße
ensemble_WG3 <- ensemble_WG3 %>%
mutate(Prognose_zuhoch = (Umsatz_ensemble >= Umsatz)) %>%
mutate(Abweichung = Umsatz_ensemble - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_ensemble - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_ensemble - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# ergänze die Anzahl
ensemble_WG3 <- ensemble_WG3 %>%
group_by(Warengruppe) %>%
mutate(Anzahl = n())
# ergänze eine weitere Hilfsgröße
ensemble_WG3 <- ensemble_WG3 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# ermittle die Gütemaße
temp <- ensemble_WG3 %>%
group_by() %>%
mutate(Verfahren="Ensemble") %>%
mutate(Modell="MW") %>%
mutate(Warengruppe=3) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen an Vergleichstabelle
ensemble_WG_vgl <- rbind(ensemble_WG_vgl, temp)
# Warengruppe 4
# bilde Ensemble-Umsatz
ensemble_WG4 <- ensemble_WG4 %>%
mutate(Umsatz_ensemble = (Umsatz_naiv + Umsatz_lm + Umsatz_dt + Umsatz_SVM + Umsatz_MLP) / 5)
# bilde Hilfsgrößen für die spätere Ermittlung der Gütemaße
ensemble_WG4 <- ensemble_WG4 %>%
mutate(Prognose_zuhoch = (Umsatz_ensemble >= Umsatz)) %>%
mutate(Abweichung = Umsatz_ensemble - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_ensemble - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_ensemble - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# ergänze die Anzahl
ensemble_WG4 <- ensemble_WG4 %>%
group_by(Warengruppe) %>%
mutate(Anzahl = n())
# ergänze eine weitere Hilfsgröße
ensemble_WG4 <- ensemble_WG4 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# ermittle die Gütemaße
temp <- ensemble_WG4 %>%
group_by() %>%
mutate(Verfahren="Ensemble") %>%
mutate(Modell="MW") %>%
mutate(Warengruppe=4) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen an Vergleichstabelle
ensemble_WG_vgl <- rbind(ensemble_WG_vgl, temp)
# Warengruppe 5
# bilde Ensemble-Umsatz
ensemble_WG5 <- ensemble_WG5 %>%
mutate(Umsatz_ensemble = (Umsatz_naiv + Umsatz_lm + Umsatz_dt + Umsatz_SVM + Umsatz_MLP) / 5)
# bilde Hilfsgrößen für die spätere Ermittlung der Gütemaße
ensemble_WG5 <- ensemble_WG5 %>%
mutate(Prognose_zuhoch = (Umsatz_ensemble >= Umsatz)) %>%
mutate(Abweichung = Umsatz_ensemble - Umsatz) %>%
mutate(Abweichung_abs = abs(Umsatz_ensemble - Umsatz)) %>%
mutate(Abweichung_rel = (Umsatz_ensemble - Umsatz) / Umsatz) %>%
mutate(Abweichung_quad = Abweichung^2)
# ergänze die Anzahl
ensemble_WG5 <- ensemble_WG5 %>%
group_by(Warengruppe) %>%
mutate(Anzahl = n())
# ergänze eine weitere Hilfsgröße
ensemble_WG5 <- ensemble_WG5 %>%
mutate(Abweichung_rel_abs = abs(Abweichung_rel), Abweichung_rel_abs_mult_umsatz = Abweichung_rel_abs * Umsatz)
# ermittle die Gütemaße
temp <- ensemble_WG5 %>%
group_by() %>%
mutate(Verfahren="Ensemble") %>%
mutate(Modell="MW") %>%
mutate(Warengruppe=5) %>%
group_by(Verfahren, Modell, Warengruppe) %>%
summarise(Anzahl=n(), Umsatz_ges = round(sum(Umsatz)), Umsatz_mittel = round(sum(Umsatz)/n()), MAE = round(mean(Abweichung_abs)), MPE = round(mean(Abweichung_rel)*100), MAPE = round(mean(Abweichung_rel_abs)*100), WAPE = round(sum(Abweichung_rel_abs_mult_umsatz)/sum(Umsatz)*100), MSE = round(mean(Abweichung_quad)), RMSE = round(sqrt(mean(Abweichung_quad))), rRMSE = round(RMSE/Umsatz_mittel*100))
# Anfügen an Vergleichstabelle
ensemble_WG_vgl <- rbind(ensemble_WG_vgl, temp)Die Gütekennzahlen für die Ensemble-Modelle fügen wir nun an die oben ermittelte Vergleichstabelle modell_vergleich_WG an.
Und schließlich vergleichen wir die besten Einzelmodelle je Warengruppe nun zusätzlich mit dem Ensemble-Schätzer.
## # A tibble: 6 x 13
## # Groups: Verfahren, Modell [6]
## Verfahren Modell Warengruppe Anzahl Umsatz_ges Umsatz_mittel MAE MPE
## <chr> <chr> <dbl> <int> <dbl> <dbl> <dbl> <dbl>
## 1 Ensemble MW 1 346 45738 132 24 -3
## 2 lm best21 1 346 45738 132 25 -8
## 3 SVM WG1 1 346 45738 132 25 -6
## 4 MLP mod2 1 346 45738 132 27 -4
## 5 DT WG1 1 346 45738 132 28 -6
## 6 naiv glDS_~ 1 358 47292 132 30 9
## # ... with 5 more variables: MAPE <dbl>, WAPE <dbl>, MSE <dbl>,
## # RMSE <dbl>, rRMSE <dbl>
Für die Warengruppe 1 liefert das Ensemble den besten Schätzer und hat das lineare Modell auf den 2. Platz verwiesen, zumindest was den WAPE anbelangt, den wir als Kriterium für die Rangfolge festgelegt haben.In Sachen rRMSE performt das lineare Modell weiterhin besser.
Für Warengruppe 1 konnten wir durch die Ensemble-Bildung den Schätzer also noch verbessern.
## # A tibble: 6 x 13
## # Groups: Verfahren, Modell [6]
## Verfahren Modell Warengruppe Anzahl Umsatz_ges Umsatz_mittel MAE MPE
## <chr> <chr> <dbl> <int> <dbl> <dbl> <dbl> <dbl>
## 1 MLP mod4 2 346 130413 377 39 2
## 2 Ensemble MW 2 346 130413 377 36 3
## 3 naiv glDS_~ 2 358 135858 379 41 1
## 4 lm best24 2 346 130413 377 40 3
## 5 SVM WG2 2 346 130413 377 42 2
## 6 DT WG2 2 346 130413 377 50 4
## # ... with 5 more variables: MAPE <dbl>, WAPE <dbl>, MSE <dbl>,
## # RMSE <dbl>, rRMSE <dbl>
modell_vergleich_WG %>%
select(Warengruppe, Verfahren, Modell, MPE, WAPE, rRMSE) %>%
filter(Warengruppe == 5) %>%
arrange(WAPE)## # A tibble: 6 x 6
## # Groups: Verfahren, Modell [6]
## Warengruppe Verfahren Modell MPE WAPE rRMSE
## <dbl> <chr> <chr> <dbl> <dbl> <dbl>
## 1 5 lm best8 1 14 19
## 2 5 Ensemble MW 1 14 21
## 3 5 DT WG5 0 15 25
## 4 5 naiv glDS_4T_erw 2 16 34
## 5 5 SVM WG5 0 16 21
## 6 5 MLP mod2 -1 16 21
Für Warengruppe 2 erreicht das Ensemble den zweiten Platz und bleibt damit knapp hinter dem MLP zurück.
## # A tibble: 6 x 13
## # Groups: Verfahren, Modell [6]
## Verfahren Modell Warengruppe Anzahl Umsatz_ges Umsatz_mittel MAE MPE
## <chr> <chr> <dbl> <int> <dbl> <dbl> <dbl> <dbl>
## 1 naiv glDS_~ 3 358 61867 173 26 3
## 2 Ensemble MW 3 346 59316 171 28 -6
## 3 lm best30 3 346 59316 171 31 -8
## 4 SVM WG3 3 346 59316 171 32 -7
## 5 MLP mod2 3 346 59316 171 34 -9
## 6 DT WG32 3 346 59316 171 36 -7
## # ... with 5 more variables: MAPE <dbl>, WAPE <dbl>, MSE <dbl>,
## # RMSE <dbl>, rRMSE <dbl>
Für Warengruppe 3 liefert nach wie vor das naive Modell die besten Schätzer, allerdings nur knapp vor dem Ensemble-Modell.
## # A tibble: 6 x 13
## # Groups: Verfahren, Modell [6]
## Verfahren Modell Warengruppe Anzahl Umsatz_ges Umsatz_mittel MAE MPE
## <chr> <chr> <dbl> <int> <dbl> <dbl> <dbl> <dbl>
## 1 Ensemble MW 4 345 28354 82 16 9
## 2 naiv glDS_~ 4 357 29606 83 17 5
## 3 DT WG4 4 345 28354 82 17 6
## 4 lm best1 4 345 28354 82 18 14
## 5 MLP mod2 4 345 28354 82 18 5
## 6 SVM WG4 4 345 28354 82 19 14
## # ... with 5 more variables: MAPE <dbl>, WAPE <dbl>, MSE <dbl>,
## # RMSE <dbl>, rRMSE <dbl>
Für Warengruppe 4 können wir mit dem Ensemble die Prognosegüte noch minimal verbessern.
## # A tibble: 6 x 13
## # Groups: Verfahren, Modell [6]
## Verfahren Modell Warengruppe Anzahl Umsatz_ges Umsatz_mittel MAE MPE
## <chr> <chr> <dbl> <int> <dbl> <dbl> <dbl> <dbl>
## 1 lm best8 5 346 93912 271 39 1
## 2 Ensemble MW 5 346 93912 271 37 1
## 3 DT WG5 5 346 93912 271 41 0
## 4 naiv glDS_~ 5 358 97639 273 43 2
## 5 SVM WG5 5 346 93912 271 43 0
## 6 MLP mod2 5 346 93912 271 43 -1
## # ... with 5 more variables: MAPE <dbl>, WAPE <dbl>, MSE <dbl>,
## # RMSE <dbl>, rRMSE <dbl>
Für Warengruppe 5 gewinnt das lineare Modell, jetzt knapp vor dem Ensemble-Modell.
Insgesamt gelingt die Umsatzschätzung für die Warengruppe 2 (= Brötchen) am besten. Wir wollen uns exemplarisch für diese Warengruppe daher noch die Verteilung der relativen Abweichungen der Umsatzschätzung vom tatsächlichen Umsatz angucken und erstellen dafür eine weitere Vergleichstabelle ensemble_WG2_vgl_relAbw. Diese müssen wir dann noch pivotisieren (pivot_longer) als Vorbereitung auf den Boxplot:
# füge die relativen Abweichungen für das naive Modell an
ensemble_WG2_vgl_relAbw <- ensemble_WG2 %>%
group_by() %>%
mutate(naiv = (Umsatz_naiv - Umsatz) / Umsatz) %>%
dplyr::select(Datum, naiv)
# füge die relativen Abweichungen für das lineare Modell an
ensemble_WG2_vgl_relAbw <- left_join(ensemble_WG2_vgl_relAbw, ensemble_WG2 %>%
group_by() %>% mutate(lm = (Umsatz_lm - Umsatz) / Umsatz) %>%
dplyr::select(Datum, lm),by="Datum")
# füge die relativen Abweichungen für das DT Modell an
ensemble_WG2_vgl_relAbw <- left_join(ensemble_WG2_vgl_relAbw, ensemble_WG2 %>%
group_by() %>% mutate(dt = (Umsatz_dt - Umsatz) / Umsatz) %>%
dplyr::select(Datum, dt),by="Datum")
# füge die relativen Abweichungen für das SVM Modell an
ensemble_WG2_vgl_relAbw <- left_join(ensemble_WG2_vgl_relAbw, ensemble_WG2 %>%
group_by() %>% mutate(SVM = (Umsatz_SVM - Umsatz) / Umsatz) %>%
dplyr::select(Datum, SVM),by="Datum")
# füge die relativen Abweichungen für das MLP Modell an
ensemble_WG2_vgl_relAbw <- left_join(ensemble_WG2_vgl_relAbw, ensemble_WG2 %>%
group_by() %>% mutate(MLP = (Umsatz_MLP - Umsatz) / Umsatz) %>%
dplyr::select(Datum, MLP),by="Datum")
# füge die relativen Abweichungen für das Ensemble Modell an
ensemble_WG2_vgl_relAbw <- left_join(ensemble_WG2_vgl_relAbw, ensemble_WG2 %>%
group_by() %>% mutate(Ensemble = (Umsatz_ensemble - Umsatz) / Umsatz) %>%
dplyr::select(Datum, Ensemble),by="Datum")
# pivotisieren
ensemble_WG2_vgl_relAbw <- ensemble_WG2_vgl_relAbw %>%
pivot_longer(cols=-c("Datum"), names_to="Modell", values_to="Abweichung_rel")
# Boxplot
ensemble_WG2_vgl_relAbw %>%
ggplot(mapping=aes(x=Modell, y=Abweichung_rel*100)) +
geom_boxplot() + coord_flip() +
ggtitle("2018 - WG2, Vergleich der besten Modelle: Rel. Abweichung") +
xlab("Modell") +
ylab("rel. Abweichung (%)") +
ylim(-100, 200)Wir sehen inder Tat, dass sich die Umsätze für die Warengruppe 2 sehr gut prognostizieren lassen. Die Verteilungen der relativen Abweichungen sind verhältnismäßig schmal.
12 Zusammenfassung und Ausblick
Die nachfolgende Tabelle ermöglicht einen Vergleich der angewendeten Modelle für alle Warengruppen:
Im Vergleich der besten Einzelmodelle finden wir ein Kopf-an-Kopf-Rennen zwischen dem besten naiven Modell und den linearen Modellen, aber auch das MLP ist bei den besten Schätzern vertreten, zumindest für eine Warengruppe. Die Entscheidungsbäume performen für die Warengruppen 1, 2 und 3 eher schlecht, für die Warengruppen 4 und 5 jedoch sehr gut (jeweils Platz 2). Die Support Vector Machines liefern insgesamt etwas schlechtere Ergebnisse. Das zeigt zum einen, dass es sehr viel Erfahrung braucht, um diese komplexen Modelle zu optimieren. Diese Erfahrung fehlt uns.
Ein weiterer Aspekt ist, dass wir alle Modelle statisch auf die Testdaten für das Jahr 2018 angewendet und die Ergebnisse verglichen haben. In einer Ausbaustufe könnte man stattdessen die komplexen Modelle nach-trainieren. Konkret könnte man dazu bspw. für die Ermittlung der Februar-Prognose schon die dann bekannten Januar-Werte aus 2018 nutzen, um die Modellparameter anzupassen. Dieses rollierende Verfahren wurde hier jedoch nicht angewendet. Die ermittelten Gütemaße könnten für die komplexen Modelle dadurch sicherlich noch verbessert werden.
Auf der anderen Seite lassen sich die Umsätze mit unserem Datenmodell vielleicht auch gar nicht besser schätzen. Möglicherweise bringt erst die Berücksichtigung weiterer Einflussfaktoren genauere Schätzergebnisse, hier aber nicht weiter vertieft.
Durch einfache Ensemble-Bildung als Mittelwert der besten Einzelschätzer konnten wir für die Warengruppen 1 und 4 die Prognosegüte noch verbessern. Bei den anderen Warengruppen reicht es zwar “nur” für den 2. Platz, aber es wird deutlich, dass schon durch eine solch einfache Ensemble-Bildung sichtbar Verbesserungen gegenüber Einzelmodellen erzielt werden können.
Insgesamt lassen sich die Umsätze für die Warengruppe 2 (= Brötchen) am treffsichersten voraussagen. Brötchen scheinen also eine “Konstante” im Leben vieler Menschen hierzulande zu sein.